a retry of the when coroutine

parent df35e3f4
(define-module (logic guile-log attributed)
#:use-module (logic guile-log code-load)
#:use-module (ice-9 format)
#:export (add-attribute-printer
attribute-printer-ref
att-printer)
......@@ -26,4 +27,4 @@
(format port "@<~{~a,~}>"
(map (lambda (x)
((attribute-printer-ref (car x)) (car x) (cdr x) s))
(gp-att-data x s))))
(pk (gp-att-data x s)))))
......@@ -2,7 +2,7 @@
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:export (attvar put_attr get_attr del_attr raw_attvar
#:export (attvar put_attr get_attr get_attrs del_attr raw_attvar
construct_attr))
(<define> (attvar X) (<attvar?> X))
......@@ -18,9 +18,9 @@
(<define> (get_attr Var Mod Val)
(<let> ((Mod (<lookup> Mod))
(Var (<lookup> Var)))
(<if> (atom CUT Mod)
(<get-attr> Var Mod Val)
(type_error Mod atom))))
(<if> (atom CUT Mod)
(<get-attr> Var Mod Val)
(type_error Mod atom))))
(<define> (construct_attr Y L)
......@@ -34,12 +34,14 @@
(()
(<cut> <cc>)))))
(<define> (get_attrs x m v) (<get-attrs> x m v))
(<define> (raw_attvar x z)
(<let> ((x (<lookup> x)))
(<if> (attvar x)
(<and>
(<values> (y) (<raw-attvar> x))
(<=> z x))
(<=> z y))
(type_error x attvar))))
(<define> (del_attr Var Mod)
......
......@@ -46,32 +46,30 @@ frozen(Var,Goal) :-
%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,#t) :-
var(Val) -> (Val = Var) ;
(
attvar(Val) ->
(
write('does not support att = att atm'),nl
) ;
(
(raw_attvar(Var, Raw), var(Raw)) ->
( var(scm[doWhen]) ->
(
get_attr(Var,whenId,Atts),!,
Raw = Val,
do_all_atts_when(Atts)
);
Raw=Val
) ;
Raw=Val
)
).
do_all_atts_when(Val,[Id, u(J,G) | L]) :-
Val=J, call(G) -> (do_all_atts_when(Val,L)) ; true.
do_all_atts_when([]).
doVs(X,[]).
doVs(X,[X|Vs]) :- doVs(X,Vs).
doNs(X,[]).
doNs(X,[N|Ns]) :- (nonvar(X) -> N=true) , doNs(X,Ns).
doGs(X,[]).
doGs(X,[G|Gs]) :- (atomic(X) -> G=true) , doGs(X,Gs).
whenId(Val,Var,#t) :-
raw_attvar(Var, Raw),
(
Raw = Val,
get_attr(Var,whenId,[G,M,Vs,Ns,Gs]),!,
doVs(Raw,Vs),doNs(Raw,Ns),doGs(Raw,Gs),
\\+M -> true , call(G)
);
Raw=Val.
difId(Val, Var, #t) :-
var(Val);attvar(Val);
......@@ -82,50 +80,61 @@ difId(Val, Var, #t) :-
do_all_atts_when(Atts)
).
process_cond((X,Y), Vars) :- !,
process_cond(X,Vars1),
process_cond(Y,Vars2),
append(Vars1,Vars2,Vars).
process_cond((X;Y), Vars) :- !,
process_cond(X,Vars1),
process_cond(Y,Vars2),
append(Vars1,Vars2,Vars).
% This is very non multithreading, let doWhen be a kanren style variable and
% we are golden.
process_cond(X=Y, [X], ((\\+(scm[doWhen] = true, X=Y)) -> false ; true))
:- !.
process_cond(nonvar(X), [X], nonvar(X))
:- !.
%process_cond(ground(X), [X], ground(X))
% :- !.
mk_cond(V, Cond, Goal, Res) :- Res = Cond.
membereq(X, [A|B]) :- (X==A,!) ; membereq(X,B).
do_when(Cond, Goal, [V|Vs], Id, Did) :-
(
(get_attr(V, Did, [U|Attr]),
( membereq(Id, Attr) ->
true ;
(
mk_cond(V,Cond,Goal,M),
put_attr(V, Did, [U,Id,M|Attr])
)
)
);
(
mk_cond(V,Cond,Goal,M),
put_attr(V, Did, [U, Id, M])
)
),
do_when(Cond, Goal, Vs, Did).
when(Cond, Goal) :-
process_cond(Cond,Vars,Cond2), do_when(Cond2, Goal, Vars, Id, whenId).
process_cond(M,(X,Y),L,LL) :- !,
process_cond(Mx,X,L,LL1),
process_cond(My,Y,LL1,LL),
M=(Mx,My).
process_cond(M,(X;Y),L,LL) :- !,
process_cond(Mx,X,L,LL1),
process_cond(My,Y,LL1,LL),
M=(Mx;My).
process_cond(M,X=Y,L,LL)
process_cond2(Mx,X,L,LL1),
process_cond2(My,Y,LL1,LL),
M=(Mx=My).
process_cond(M,nonvar(X),L,LL) :-
add_nonvar(M,X,L,LL).
process_cond(M,ground(X),L,LL) :-
add_ground(M,X,L,LL).
process_cond(M,[X|Y],L,LL)
process_cond2(Mx,X,L,LL1),
process_cond2(My,Y,LL1,LL),
M=[Mx|My].
process_cond2(M,X,L,LL) :-
var(X) -> add_var(M,X,L,LL) ;
X~=[F|U] -> (process_cond2(MM,U,L,LL),M~=[F|MM]) ;
(M=X,L=LL).
add_var(MG,G,M,X,L,LL) :-
hash_ref(L,X,[Vs|U],LL) -> hash_set_x(X,[[M|Vs]|U,LL) ;
hash_set_x(X,[[M],[],[]],LL).
add_nonvar(MG,G,nonvar(M),X,L,LL) :-
hash_ref(L,X,[Vs,Ns,Gs],LL) -> hash_set_x(X,[Vs,[M|Ns],Vs],LL) ;
hash_set_x(X,[[],[M],[]],LL).
add_ground(MG,G,nonvar(M),X,L,LL) :-
hash_ref(L,X,[Vs,Ns,Gs],LL) -> hash_set_x(X,[Vs,Ns,[M|Gs]],LL) ;
hash_set_x(X,[[],[],[M]],LL).
construct_when(MG,G,[]).
construct_when(MG,G,[[X|Data] | L]) :-
(
get_attr(X,whenId,L) ->
put_attr(X,whenId,[[MG,G | Data] | L]) ;
put_attr(X,whenId,[[MG,G | Data]]).
), construct_when(MG,G,L).
when(Cond,Goal) :-
process_when(Cond,MG,Data),
construct_when(MG,G,Data).
diff(X, Y) :-
do_when(X=Y, X\\== Y, [X], Id, diffId).
......
......@@ -17,14 +17,16 @@
(define readline_
(if (provided? 'readline)
(@ (ice-9 readline) readline)
(lambda (pr)
(format #t "~a" pr)
(read-line))))
(begin
(warn "readline is not installed - read the guile manual about scheme interactive use")
(lambda (pr)
(format #t "~a" pr)
(read-line)))))
(define add-history
(if (provided? 'readline)
(@ (ice-9 readline) add-history)
(error "readline is not installed - read the guile manual about scheme interactive use")))
(lambda (pr) pr)))
(define repl ((@@ (system repl repl) make-repl) 'scheme #f))
......
......@@ -1086,7 +1086,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<define> (<get-attrs> x m v)
(<let> ((x (<lookup> x)))
(when (gp-attvar-raw? x S)
(<let> ((l (gp-att-data x S)))
(<let> ((l (gp-att-data x S)))
(<recur> lp ((l l))
(<match> (#:mode +) (l)
(((,m . ,v) . l)
......@@ -1098,8 +1098,10 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(when x (<cc> x))))
(<define> (<get-attr> x m v)
(<let> ((ret (gp-get-attr x m S)))
(when ret (<=> v ret))))
(<let*> ((x (<lookup> x))
(ret (gp-get-attr x m S)))
(when ret (<=> v ,(pk 'a ret)))))
(<define> (<del-attr> x m) (<with-s> (gp-del-attr x m S) <cc>))
......@@ -49,8 +49,9 @@
(apply xx x)))
(define-syntax-rule (define-or-set! f x)
(letrec ((xx x)
(f (mktr 'f xx)))
(letrec* ((xx x)
(f (mktr 'f xx)))
(set-procedure-property! xx 'name 'f)
(if (module-locally-bound? (current-module) 'f)
(module-set! (current-module) 'f f)
(define! 'f f))
......@@ -322,7 +323,7 @@
(let* ((syms (get-syms))
(syms (union syms syms)))
(pp 'res #`(begin
(ppp 'res #`(begin
(eval-when (compile load eval)
(add-non-defined
(quote #,(datum->syntax stx syms))))
......
......@@ -218,7 +218,7 @@
((@@) #`(unquote (@wrapper `#,(fget v) '#,li #t S))))))
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
#`,#,(mk-scheme stx s l #t))
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
#`(unquote #,(compile-lambda stx l s closed?)))
......@@ -320,7 +320,7 @@
((#:@ v type li)
(warn "Namedspace in fkn match position is not supported"))
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #f))
#`,#,(mk-scheme stx s l #f))
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
(compile-lambda stx l s closed?))
......@@ -447,7 +447,7 @@
#`(unquote (@wrapper `#,(fget v) '#,li #t S))))))
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
#`,#,(mk-scheme stx s l #t))
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
#`(unquote #,(compile-lambda stx l s closed?)))
......
......@@ -206,7 +206,7 @@ SCM_DEFINE(gp_get_attr, "gp-get-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
ref = gp_lookup2(GP_GETREF(x), l);
if(1)
if(GP(x))
{
if(GP_ATTR(ref))
{
......@@ -226,6 +226,7 @@ SCM_DEFINE(gp_get_attr, "gp-get-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
{
return SCM_CDAR(l);
}
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));
......
......@@ -68,6 +68,7 @@
gp-attvar?
gp-attvar-raw?
gp-att-raw-var
gp-att-data
gp-put-attr
gp-get-attr
......
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