coroutines updates

parent 66e1c321
......@@ -285,4 +285,6 @@
(vlist-cons (car l) (lp (cdr l)))))
r)))
(gp-set-attribut-trampoline (lambda (lam val var x y s)
(lam s (lambda () #f) (lambda (s .l) s)
val var x y)))
(define-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog error)
#:use-module (#:select (logic guile-log prolog names)
(atom))
#:export (attvar put_attr get_attr del_attr construct_attr))
(<define> (attvar X) (<attvar?> X))
(<define> (put_attr Var Mod Val)
(<if> (<attvar?> Var)
(<if> (atom Mod)
(<put-attr> Var Mod Val)
(type_error Mod atom))
(representation_error Var)))
(<define> (get_attr Var Mod Val)
(<if> (atom Mod)
(<get-attr> Var Mod)
(type_error Mod atom)))
(<define> (del_attr Var Mod)
(<if> (atom Mod)
(<del-attr> Var Mod)
(type_error Mod atom)))
(<define> (construct_attr Y L)
(<recur> lp ((L L))
(<match> (#:mode -) (L)
(((A . B) . L)
(<cut>
(<put-attr> Y A B)
(lp L)))
(()
(<cut> <cc>)))))
\ No newline at end of file
(define-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog attribute)
#:export (feeeze frozen when dif))
(compile-prolog-string
"
do_all_atts([G|L]) :- call(G),!, do_all_atts(L).
do_all_atts([]).
% The unification algorithm
freezeId(Val, Var) :-
var(Val);attvar(Val);
(
get_attr(Var,freezeId, Atts),
do_all_atts(Atts),
del_attr(Var, freezeId),
Var = Val;
).
freeze(Var,Goal) :-
(var(Var),
( get_attr(Var, freezeId, Att),!,
Att2 = [Goal|Att],
put_attr(Var, freezeId, Att2)
);
put_attr(Var, freezeId, [Att|NewVar]));
call(Goal).
combine_atts([G,U |L], (G;GL)) :- combine_atts([U|L], GL),!.
combine_atts([G], G).
combine_atts([],true).
frozen(Var,Goal)
(
get_attr(Var, freezeId, Atts),!,
combine_atts(Atts,Goal)
) ;
Goal = true.
whenId(Val,Var)
%when(Condition, Goal)
do_all_atts_when(Val, [Id, G | L]) :-
call(G) -> (!,do_all_atts_when(Val, L)) ; (!,do_all_atts_when(Val, L)).
do_all_atts_when(Val, []).
whenId(Val, Var)
var(Val);attvar(Val);
(
get_attr(Var,whenId, Atts),
del_attr(Var, whenId),
Var = Val;
do_all_atts_when(Atts),
).
difId(Val, Var)
var(Val);attvar(Val);
(
get_attr(Var,whenId, Atts),
del_attr(Var, whenId),
Var = Val;
do_all_atts_when(Atts),
).
process_goal((X,Y), Vars) :- !,
process_cond(X,Vars1),
process_cond(Y,Vars2),
append(Vars1,Vars2,Vars).
process_goal((X;Y), Vars) :- !,
process_cond(X,Vars1),
process_cond(Y,Vars2),
append(Vars1,Vars2,Vars).
process_cond(X=Y, [X]) :- !.
process_cond(nonvar(X), [X]) :- !.
%process_cond(ground(X), [X]) :- !.
mk_cond(V, Cond, Goal, Res) :- Res = (\\+Cond -> fail ; Goal).
membereq(X, [A|B]) :- (X==A,!) ; membereq(X,B).
do_when(Cond, Goal, [V|Vs], Id, Did) :-
(
(get_attr(V, Did, Attr)
( membereq(Id, Attr) ->
fail ;
(
mk_cond(V,Cond,Goal,M),
put_attr(V, Did, [Id,M|Attr]
)
)
);
mk_cond(V,Cond,Goal,M), put_attr(V, Did, [Id, M])
),
do_when(Cond, Goal, Vs, Did).
when(Cond, Goal) :-
process_cons(Cond,Vars), do_when(Cond, Goal, Vars, Id, whenId).
diff(X, Y) :-
do_when(X=Y, X\\== Y, [X], Id, diffId).
")
\ No newline at end of file
......@@ -33,6 +33,7 @@
<define-guile-log-rule>
<get-fixed> <cp> <lookup> <wrap>
<with-bind>
<attvar?> <put_attr> <get_attr> <del_attr>
))
......@@ -1077,3 +1078,12 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(syntax-rules ()
((_ w a ...)
(<with-guile-log> w code ...)))))
(<define> (<attvar?> x) (if (gp-attvar? x) <cc> <fail>))
(<define> (<put-attr> x m v) (<with-s> (gp-putvar x m v) <cc>))
(<define> (<get-attr> x m v)
(<let> ((ret (gp-get-attr x m)))
(when ret (<=> v ret))))
(<define> (<del-attr> x m) (<with-s> (gp-del-attr x m) <cc>))
......@@ -433,15 +433,22 @@
(()
(nl (fluid-ref *current-output*)))))
(define qt (cons 'quoted 'var))
(define* (scm->pl s x #:optional (ns? #f) (quoted? #f) (ignore? #f) (numbervars? #f))
(define *variables* (make-hash-table))
(define *closures* (make-hash-table))
(define i 0)
(define (next)
(let ((s (string-append "X" (number->string i))))
(set! i (+ i 1))
s))
(define (next-q)
(cons qt
(let ((s (string-append "X" (number->string i))))
(set! i (+ i 1))
s)))
(define (list-it x)
(umatch (#:mode - #:status s #:name list-it) (x)
((a . (and x (b . l)))
......@@ -468,7 +475,9 @@
(define (lp x)
(umatch (#:mode - #:status s #:name scm->pl) (x)
(#((f a . l))
(let ((f (gp-lookup f s)))
(let ((f (gp-lookup f s))
(x (gp-lookup x s)))
(cond
((string? f)
(format #f "'~a'(~a~{, ~a~})" f (lp a) (map lp (gp->scm l s))))
......@@ -477,9 +486,15 @@
(let ((args (map lp (prolog-closure-state f)))
(pre (lp (vector (cons* (prolog-closure-parent f) l)))))
(if quoted?
(if (not (pair? args))
(format #f "~a[]" pre)
(format #f "~a[~a~{,~a~}]" pre (car args) (cdr args)))
(let ((n (hashq-ref *closures* x #f)))
(if n
(format #f "~a[n]" pre)
(let ((n (next)))
(hashq-set! *closures* x n)
(if (not (pair? args))
(format #f "~a[~a]" pre n)
(format #f "~a[~a,~a~{,~a~}]" pre n
(car args) (cdr args))))))
(format #f "~a#~a"
(number->string
(object-address (prolog-closure-closure f))
......@@ -526,7 +541,9 @@
(gen@ ll f) (car ll) (cdr ll)))))))
((a . l)
(format #f "[~a]" (list-it x)))
(if (eq? qt a)
l ; we have in a previous pass decided about an attributed variable
(format #f "[~a]" (list-it x))))
(a
(let ((a (gp-lookup a s)))
......@@ -541,6 +558,14 @@
(cons* #\' #\' (lp (cdr l)))
(cons x (cdr l))))
'())))))
((gp-attr-raw? a s)
(let ((r (hashq-ref *variables* a #f)))
(if r
r
(let ((n (next-q)))
(hashq-set! *variables* a n)
(gen@ (vector (list construct_attr n (gp-att-data a))))))))
((gp-var? a s)
(let ((r (hashq-ref *variables* a #f)))
......@@ -681,12 +706,13 @@
((n x)
(<pp> `(,n ,x)))))
(<define> (read* s term v vn si)
(<define> (read* s term v vn si)
(<let*> ((s (<scm> s))
(e (call-with-values
(lambda () (read-prolog-term S s (current-module)))
(lambda x x))))
(<=> ,(list term v vn si) e)))
(<=> ,(list term v vn si) e)
(<code> (fluid-set! *closure-creations* (make-hash-table)))))
(define read_term
......
......@@ -2,7 +2,8 @@
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:export (get.. get-c pp get-binding get-refstr *prolog-file*
attach-defined-module! get-attached-module))
attach-defined-module! get-attached-module
*closure-creations*))
(define pp
(case-lambda
......@@ -109,4 +110,5 @@
(if not-pretty?
(st (module-name (current-module)))
'())))))
\ No newline at end of file
(define *closure-creations* (make-fluid (make-hash-table)))
\ No newline at end of file
......@@ -12,6 +12,18 @@
#:use-module ((logic guile-log) #:select ((_ . GL:_) <define> <code> <cc> S))
#:export (arg var var_ pat-match term-init-variables v-variables
term-get-variables-list term-get-variables term))
(define (metah lam n . l)
(if (null? l)
(let ((f (hashq-ref (fluid-ref *closure-creations*) n #f)))
(if f
f
(error "closure references failed could not find stored ref of already made closure")))
(begin
(let ((f (apply lam l)))
(hashq-set! (fluids-ref *closure-creations*) f)
f))))
(define arg #f)
(define arg-goal #f)
(define compile-lambda #f)
......@@ -78,7 +90,7 @@
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
#`(unquote (#,(get-binding mod local? atom stx fa) #,@meta))))
#`(unquote (metah #,(get-binding mod local? atom stx fa) #,@meta))))
((#:term (and atom (#:atom f . _)) x #f . _)
(add-sym mod local? atom)
......@@ -92,7 +104,7 @@
(let ((meta (map fget (get.. "," meta))))
#`(unquote
(vector
`(,(#,(get-binding mod local? atom stx fa) #,@meta)
`(,(metah #,(get-binding mod local? atom stx fa) #,@meta)
#,@(map fget (get.. "," x)))))))
((#:termvar v () . _)
......@@ -217,7 +229,7 @@
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym mod local? atom)
(let ((meta (if (null? meta) meta (map fget (get.. "," meta)))))
#`(unquote (#,(get-binding mod local? atom stx fa) #,@meta))))
#`(unquote (metah #,(get-binding mod local? atom stx fa) #,@meta))))
((#:term (and atom (#:atom f . _)) x #f . _)
......@@ -232,7 +244,7 @@
(let ((meta (if (null? meta) meta (map fget (get.. "," meta)))))
#`(unquote
(vector
`(,(#,(get-binding mod local? atom stx fa) #,@meta)
`(metah ,(#,(get-binding mod local? atom stx fa) #,@meta)
#,@(map fget (get.. "," x)))))))
((#:termvar v () . _)
......@@ -320,7 +332,7 @@
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
#`((get-binding mod local? atom stx fa) #,@meta)))
#`(metah (get-binding mod local? atom stx fa) #,@meta)))
((#:term (and atom (#:atom f . _)) x #f . _)
(add-sym mod local? atom)
......@@ -331,7 +343,7 @@
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
#`(vector
`(,(#,(get-binding mod local? atom stx fa) #,@meta)
`(,(metah #,(get-binding mod local? atom stx fa) #,@meta)
#,@(map fget (get.. "," x))))))
((#:termvar v () . _)
......@@ -448,7 +460,8 @@
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
#`(unquote (#,(get-binding mod local? atom stx fa)
#`(unquote (metah
#,(get-binding mod local? atom stx fa)
#,@meta))))
((#:term (and atom (#:atom f . _)) x #f . _)
......@@ -463,7 +476,8 @@
(let ((meta (map fget (get.. "," meta))))
#`(unquote
(vector
`(,(#,(get-binding mod local? atom stx fa) #,@meta)
`(,(metah #,(get-binding mod local? atom stx fa)
#,@meta)
#,@(map fget (get.. "," x)))))))
((#:termvar v () . _)
......
......@@ -34,7 +34,33 @@ SCM_DEFINE(gp_attdata, "gp-att-data", 2, 0, 0, (SCM x, SCM s),
return ref[1];
}
}
return SCM_UNBOUND;
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE(gp_put_attdata, "gp-att-put-data", 2, 0, 0, (SCM x, SCM v, SCM s),
"check to see if variable is an attributed variable")
#define FUNC_NAME s_gp_put_attdata
{
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_UNBOUND(ref))
{
SCM pt = v;
while(SCM_CONSP(pt))
{
s = gp_put_attr(x, SCM_CAAR(pt), SCM_CDR(pt), s);
if(scm_is_false(s)) break;
pt = SCM_CDR(pt);
}
}
}
return s;
}
#undef FUNC_NAME
......@@ -108,7 +134,7 @@ SCM_DEFINE(gp_put_attr, "gp-put-attr", 4, 0, 0,
SCM newvar = GP_IT(gp_mk_var(s));
s = gp_ref_set
(GP_UNREF(ref), scm_cons(scm_cons(lam, newvar), it), s);
s = gp_ref_set(newvar, val, s);
s = gp_ref_attr_set(newvar, val, s);
}
}
}
......@@ -163,21 +189,21 @@ SCM_DEFINE(gp_get_attr, "gp-get-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
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;
return SCM_BOOL_F;
}
}
else
return SCM_UNBOUND;
return SCM_BOOL_F;
}
else
return SCM_UNBOUND;
return SCM_BOOL_F;
}
else
return SCM_UNBOUND;
return SCM_BOOL_F;
}
#undef FUNC_NAME
#define DB(X)
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
......@@ -189,12 +215,14 @@ SCM_DEFINE(gp_del_attr, "gp-del-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
if(GP(x))
{
SCM *ref = GP_GETREF(x);
gp_debug0("a gp~%");
if(GP_ATTR(ref))
{
SCM it = ref[1];
gp_debug0("a an attr~%");
if(GP_UNBOUND(ref))
{
return SCM_UNSPECIFIED;
return s;
}
else
{
......@@ -203,6 +231,7 @@ SCM_DEFINE(gp_del_attr, "gp-del-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
SCM r = SCM_EOL;
while(SCM_CONSP(l))
{
gp_format1("1: ~a~%",l);
if(SCM_CONSP(SCM_CAR(l)))
{
if(scm_is_eq(SCM_CAAR(l), lam))
......@@ -215,13 +244,14 @@ SCM_DEFINE(gp_del_attr, "gp-del-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
p = scm_cons(SCM_CAR(l),p);
l = SCM_CDR(l);
}
}
}
}
if(SCM_NULLP(p) && SCM_NULLP(r))
{
{
SCM l,ret,ggp,ci;
struct gp_stack *gp;
gp_format0("null null~%");
UNPACK_ALL(ci,l,ggp,gp,s,"failed to unpack s in delattr");
ret = gp_set_unbound(ref,l,gp);
......@@ -235,13 +265,15 @@ SCM_DEFINE(gp_del_attr, "gp-del-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
r = scm_cons(SCM_CAR(p),r);
p = SCM_CDR(p);
}
gp_format1("tt: ~a~%",r);
s = gp_ref_set(x, r, s);
}
}
}
}
}
#define DB(X)
return s;
}
#undef FUNC_NAME
......@@ -405,6 +405,8 @@ static inline void gp_store_var_2(SCM *id, int simple, struct gp_stack *gp)
{
GP_TEST_CSTACK;
gp_gc_inc(gp);
if(!GP(GP_UNREF(id)))
scm_misc_error("gp_store_var_2"," got non gp variable to set ~a",
scm_list_1(GP_UNREF(id)));
......@@ -1013,6 +1015,12 @@ static int gp_recurent(SCM *id1,SCM *id2, SCM *l)
if(GP_UNBOUND(id2)) return 0;
if(GP_ATTR(id2))
{
id2 = id2[1];
}
scm = GP_SCM(id2);
gp_debug0("linked scm\n");
retry:
......@@ -1266,6 +1274,19 @@ int len(SCM x, SCM *l)
}
//#define DB(X) X
// unify under + means unification - means just match
SCM trampoline = SCM_BOOL_F;
SCM_DEFINE(gp_set_attributed_trampoline, "gp-set-attribut-trampoline", 1, 0, 0, (SCM x),
"check to see if variable is an attributed variable")
#define FUNC_NAME s_gp_set_attributed_trampoline
{
trampoline = x;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, struct gp_stack *gp, SCM ci)
{
SCM * stack[110];
......@@ -1395,7 +1416,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
if(SCM_CONSP(SCM_CAR(xl)))
{
s =
scm_call_5(SCM_CAAR(xl), SCM_CDAR(xl),GP_UNREF(id2),
scm_call_5(trampoline, GP_UNREF(id2), GP_UNREF(id1),
scm_raw,
scm_plus, s);
......@@ -1405,7 +1426,9 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
xl = SCM_CDR(xl);
}
}
}
{
SCM ll = SCM_CDR(s);
if(vlist_p(ll))
......@@ -3110,6 +3133,10 @@ SCM_DEFINE(gp_dynwind, "gp-dynwind", 3, 0, 0, (SCM in, SCM out, SCM s),
"Wrong type of argument (in, out, s)) in gp-dynwind got ~a,~a,s",
scm_list_2(in,out));
}
GP_TEST_CSTACK;
gp_gc_inc(gp);
gp->gp_ci[0] = scm_cons(in,out);
gp->gp_ci ++;
return SCM_UNSPECIFIED;
......
......@@ -126,3 +126,5 @@ 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);
SCM_API SCM gp_set_attributed_trampoline(SCM x);
SCM_API SCM gp_put_attdata(SCM x, SCM v, SCM s),
......@@ -96,10 +96,9 @@ SCM gp_make_cons()
void init_variables()
{
#ifdef HAS_GP_GC
static int x = 0xffff;
SCM y = GP_UNREF(&x);
#ifdef HAS_GP_GC
gp_variable_gc_kind
= GC_new_kind_adv (GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (gp_mark_variable), 0),
......
......@@ -487,6 +487,12 @@
(let lp ((x x))
(let ((x (gp-lookup x s)))
(cond
((gp-attvar-raw? x)
(if (not (hashq-ref tr x #f))
(begin
(hashq-set! tr x (gp-make-var))
(gp-att-data x))))
((gp-pair? x s)
(begin
(lp (gp-car x s))
......@@ -515,6 +521,11 @@
(let lp ((x x))
(let ((x (gp-lookup x s)))
(cond
((gp-attvar-raw? x)
(let ((v (hashq-ref tr x 'BUG)))
(if (not (gp-attvar-raw? v))
(gp-att-put-data v (lp (gp-att-data x)) s))))
((gp-pair? x s)
(cons (lp (gp-car x s))
(lp (gp-cdr x s))))
......
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