new attribute and coroutine features added - not debugged and compileable

parent c561991d
......@@ -5,7 +5,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (gp-clear gp-unify!- gp-unify-raw!- gp-newframe gp-unwind
gp->scm gp-print gp-var! gp-heap-var!
gp->scm gp-print gp-heap-var!
gp-c-system
gp-budy gp-m-unify!-
gp-lookup ;gp-lookup-clean
......@@ -47,6 +47,8 @@
gp-clear-frame!
gp-gc
gp-mark-permanent
vlist? vlist-cons vlist-head vlist-tail vlist-null?
vlist-null list->vlist vlist-ref vlist-set!
......
......@@ -488,7 +488,7 @@ add/run * vlist *
(let ((fr (gp-newframe s)))
(walk-lr s p a
(lambda (p a vec)
(let ((p (lambda () (gp-unwind fr) (p))))
(let ((p (lambda () (let (gp-unwind fr) (p))))
((get-f vec) s p cc a)))))))
(setter g)
(set-object-property! g 'dynamic-data
......@@ -656,8 +656,8 @@ add/run * vlist *
S f
(lambda (data)
(let ((fr (<newframe>)))
(let ((s (gp-unify! (get-c data) y S)))
(<unwind> fr)
(let* ((s (gp-unify! (get-c data) y S)))
(<unwind> fr)
(if s #t #f))))
#t)))
......
(define-module (logic guile-log guile-prolog attributator)
#:use-module ((logic guile-log) #:select (<wrap>))
#:use-module (logic guile-log umatch)
#:export (with_attributate))
(<wrap> add-fluid-dynamics *var-attributator*)
(define (with_attributate s p cc attribute val)
(with-fluid-guard-dynamic-object s p cc *var-attributator*
(<lambda> ()
(fluid-set *var-attributator*
(cons
(cons attribute val)
((fluid-ref *var-attributator*)))))))
......@@ -13,9 +13,22 @@
(define doWhen (gp-make-var))
(define (process_unwinder s p cc code)
(let ((code (scm-unpin code s)))
(((@@ (logic guile-log umatch) dyn)
(lambda x #f)
(lambda x
(add-new-unwind-hook
(<lambda> () (eval-goal code))))
s)))
(cc p))
(compile-prolog-string
"
do_all_atts([G|L]) :- call(G),!, do_all_atts(L).
do_all_atts([[[],G|L]) :- call(G),!, do_all_atts(L).
do_all_atts([[[Unw],G|L]) :-
process_unwinder(Unwinder),call(G),!, do_all_atts(L).
do_all_atts([]).
% The unification algorithm
......@@ -33,7 +46,20 @@ freeze(Var,Goal) :-
((var(Var);attvar(Var)),
((
get_attr(Var, freezeId, Att),!,
Att2 = [Goal|Att],
Att2 = [[],Goal|Att],
put_attr(Var, freezeId, Att2)
);
(
put_attr(Var, freezeId, [Goal])
),!)
);
call(Goal).
freezeBig(Var,Goal,Unw) :-
((var(Var);attvar(Var)),
((
get_attr(Var, freezeId, Att),!,
Att2 = [[Unw],Goal|Att],
put_attr(Var, freezeId, Att2)
);
(
......@@ -65,7 +91,7 @@ doNs(X,Ns) :- var(Ns) -> true ; ([N]=Ns,nonvar(X) -> N=true).
doGs(X,Gs) :- var(Gs) -> true ; ([G]=Gs,atomic(X) -> G=true).
do_all_when(_,[]).
do_all_when(R,[[G,M,[K,O],Vs,Ns,Gs]|L]) :- !,
do_all_when(R,[[[],G,M,[K,O],Vs,Ns,Gs]|L]) :- !,
(
doVs(R,Vs),doNs(R,Ns),doGs(R,Gs),
var(O) ->
......@@ -77,12 +103,32 @@ do_all_when(R,[[G,M,[K,O],Vs,Ns,Gs]|L]) :- !,
); true
), do_all_when(R,L).
do_all_pre([]) :-!.
do_all_pre([[[Pre|_]|_]|L]) :- !,
Pre, do_all_pre(L).
do_all_when(R,[]) :- !,
do_all_when(R,[[[Pre,Unwinder],G,M,[K,O],Vs,Ns,Gs]|L]) :- !,
(
doVs(R,Vs),doNs(R,Ns),doGs(R,Gs),
var(O) ->
( (\\+call(M)) -> true ;
(
(
K=false -> O=true;true),
process_unwinder(Unwinder),
call(G)
)
); true
), do_all_when(R,L).
whenId(_,_,#f).
whenId(Val,Var,#t) :-
raw_attvar(Var, Raw) ->
(
Raw = Val,
get_attr(Var,whenId,L),
do_all_pre(L),
Raw = Val,
do_all_when(Raw,L)
);
Raw=Val.
......@@ -132,12 +178,12 @@ add_ground(nonvar(M),X,L) :-
vhashq_ref(L,X,[Vs, Ns, Gs]) -> Gs=[M] ;
vhashq_cons(L,X,[Vs, Ns, [M]]).
construct_when(O,MG,G,[]).
construct_when(O,MG,G,[[X|Data] | L]) :- !,
construct_when(Q,O,MG,G,[]).
construct_when(Q,O,MG,G,[[X|Data] | L]) :- !,
(
get_attr(X,whenId,L) ->
put_attr(X,whenId,[[G,MG,O | Data] | L]) ;
put_attr(X,whenId,[[G,MG,O | Data]])
put_attr(X,whenId,[[Q,G,MG,O | Data] | L]) ;
put_attr(X,whenId,[[Q,G,MG,O | Data]])
),
construct_when(O,MG,G,L).
......@@ -146,6 +192,15 @@ when_co(Cond,Goal) :-
construct_when([false,O],MG,Goal,Data).
whenBig(Cond,Goal,O,Pre,Unw) :-
process_when(Cond,MG,Data),
construct_when([Pre,Unw],[true,O],MG,Goal,Data).
whenBig(Cond,Goal,Pre,Unw) :-
process_when(Cond,MG,Data),
construct_when([Pre,Unw,[false,O],MG,Goal,Data).
when_co(Cond,Goal,O) :-
process_when(Cond,MG,Data),
construct_when([true,O],MG,Goal,Data).
......@@ -186,5 +241,9 @@ diff(X,Y) :- when_co(X=Y,X\\==Y).
(member M2 Xs)
(<=> V ,(car l)))
(lp (cdr l)))))))
#|
|#
......@@ -354,8 +354,10 @@ conversation_ :-
) ; conversation_.
conversation1(X,All) :-
fluid_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-], scm[-mute?-]),
state_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-], scm[-mute?-],
fluid_guard_dynamic_object(scm[*var-attributator*],scm[-n-],
scm[-nsol-], scm[-all-], scm[-mute?-]),
state_guard_dynamic_object(scm[*var-attributator*],
scm[-n-], scm[-nsol-], scm[-all-], scm[-mute?-],
scm[*user-data*]),
wrap_frame,
conversation2(X,All).
......
......@@ -51,7 +51,7 @@
(let ((sin (gp-newframe sin)))
(define fail
(lambda ()
(gp-unwind sin)
(let ((sin (gp-unwind sin)))
(let loop ((ll l) (rr r))
(if (null? ll)
(if (null? rr)
......@@ -60,7 +60,7 @@
(let ((thunk (car ll)))
(set! l (cdr ll))
(set! r rr)
(thunk))))))
(thunk)))))))
(define (mk-cont p ss)
(let ((state (gp-store-state ss)))
......@@ -86,7 +86,7 @@
(let ((s (gp-newframe sin)))
(define fail
(lambda ()
(gp-unwind s)
(let ((s (gp-unwind s)))
(let loop ((ll l) (rr r) (ggs gs) (ggr gr))
(if (null? ll)
(if (null? rr)
......@@ -97,7 +97,7 @@
(set! r rr)
(set! gs (cdr ggs))
(set! gr ggr)
(thunk))))))
(thunk)))))))
(define (mk-cont p s)
(let ((state (gp-store-state s)))
......
......@@ -155,8 +155,8 @@
(parse<> meta a)))
((_ (cut s p cc) a . as)
(let ((pp (lambda ()
(gp-unwind s)
(or-aux (cut s p cc) . as))))
(let ((ss (gp-unwind s)))
(or-aux (cut ss p cc) . as)))))
(parse<> (cut s pp cc) a)))))
(define-and-log <values>
......@@ -289,7 +289,7 @@
(syntax-rules ()
((_ (cut s p cc) g ...)
(let* ((s (gp-newframe s))
(ccc (lambda (ss pp) (gp-unwind s) (cc s p))))
(ccc (lambda (ss pp) (let ((ss (gp-unwind s))) (cc ss p))))
(parse<> (cut s p ccc) (<and> g ...))))))
......@@ -410,8 +410,8 @@
(let* ((ss (gp-newframe s))
(ccc (lambda x (p)))
(ppp (lambda ()
(gp-unwind ss)
(cc ss p))))
(let ss (gp-unwind ss)
(cc ss p)))))
(parse<> (ppp ss ppp ccc) (<and> code ...))))))
......
......@@ -12,8 +12,7 @@
#:use-module (logic guile-log prolog namespace)
#:use-module (logic guile-log guile-prolog closure)
#:export (memo rec tabling memo-rec memo-ref rec-ref table-ref
rec-once memos recs rec= rec== rec-action
with-rec-unifyer rec-unifyer rec-0 rec-once-0 rec-lam
rec-once memos recs rec= rec== rec-action with-rec-unifyer rec-unifyer rec-0 rec-once-0 rec-lam
rec-lam-once rec-lam-0 rec-lam-once-0
gp-cp-rec gp->scm-rec canon-it-rec
with-nonrec-unifyer nonrec-unifyer))
......@@ -314,6 +313,7 @@ Also it is possible to solve inifinite recursion.
(<apply> f x)))))))
(<define> (id h x) (x))
(mk-rec rec (Q with-backtrack-dynamic-object) get-tag)
(mk-rec rec-once (Q with-backtrack-dynamic-object-once) get-tag)
(mk-rec rec-0 with-backtrack-dynamic-object get-tag)
......
......@@ -508,7 +508,14 @@ static void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
}
else
{
if(scm_is_eq(*i,SCM_BOOL_T))
if(GP(*i))
{
if(GP_GC_ISQAND(SCM_UNPACK(GP_GETREF(*i)[0])))
{
*i = SCM_BOOL_F;
}
}
else if(scm_is_eq(*i,SCM_BOOL_T))
{
*i = SCM_BOOL_F;
si_store = 1;
......@@ -1305,3 +1312,19 @@ SCM_DEFINE(gp_clear_frame_x, "gp-clear-frame!", 1, 0, 0, (SCM s),
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_mark_permanent, "gp-mark-permanent", 1, 0, 0, (SCM x),
"marks a variable as permanent and hence will be removed from stacks")
#define FUNC_NAME s_gp_mark_permanent_x
{
SCM *id = GP_GETREF(x);
if(GP(x) && GP_VAR(id))
{
scm_t_bits p = SCM_UNPACK(id[0]);
GP_GC_QAND(p);
id[0] = SCM_PACK(p);
return SCM_BOOL_T;
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
......@@ -129,3 +129,5 @@ 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);
SCM_API SCM gp_att_rawvar(SCM x, SCM s);
SCM_API SCM gp_mark_permanent(SCM x);
......@@ -28,7 +28,7 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-9)
#:export (gp-member gp-right-of gp-einstein gp-next-to)
#:re-export (gp-clear #;gp-newframe gp-var! gp-heap-var!
#:re-export (gp-clear #;gp-newframe gp-heap-var!
;gp-unify! gp-unify-raw! gp-m-unify!
gp-car gp-cdr
gp-print gp?
......@@ -73,6 +73,8 @@
gp-put-attr
gp-get-attr
gp-del-attr
gp-mark-permanent
)
......@@ -88,6 +90,7 @@
gp-with-wind
gp-windlevel-ref
gp-fluid-set!
gp-var!
*gp*
*windlevel*
gp-var-set!
......@@ -101,8 +104,23 @@
gp-unify!
gp-unify-raw! gp-m-unify!
gp-unifier gp-raw-unifier gp-m-unifier
gp-scm-unpin
*unwind-hooks*
*var-attributator*
add-new-unwind-hook
#;gp-unwind))
(define *var-attributator* (make-fluid '()))
(define (gp-var! s)
(let ((v ((@@ (logic guile-log code-load) gp-var!) s)))
(let ((l (fluid-ref *var-attributator*)))
(let lp ((l (reverse l)))
(if (pair? l)
(begin
(gp-put-attr v (caar l) (cdar l) s)
(lp (cdr l))))))
v))
(define gp-unifier (make-fluid gp-unify!-))
(define gp-raw-unifier (make-fluid gp-unify-raw!-))
(define gp-m-unifier (make-fluid gp-m-unify!-))
......@@ -115,19 +133,30 @@
(gp-module-init)
(define *unwind-hooks* (make-fluid '()))
(define newf (@@ (logic guile-log code-load) gp-newframe))
(define unw (@@ (logic guile-log code-load) gp-unwind))
(define (add-new-unwind-hook lam)
(fluid-set! *unwind-hooks*
(cons lam (fluid-ref *unwind-hook*))))
(define *unwind-parameters* (make-fluid '()))
(begin
(define gp-unwind
(lambda (fr)
(fluid-set! *unwind-hooks* '())
(unw fr)
(let ((l.a (fluid-ref *unwind-parameters*)))
(if (pair? l.a)
(for-each
(lambda (f) ((car f) (cdr f)))
(cdr l.a))))))
(cdr l.a))))
(let lp ((l (reverse (fluid-ref *unwind-hooks*))) ((s fr)))
(if (pair? l)
((car l)
s (lambda () (lp (cdr l) s) (lambda (s p) (lp (cdr l) s))))
s))))
(define (gp-newframe s)
(let ((l.a (fluid-ref *unwind-parameters*)))
......@@ -341,8 +370,8 @@
(define-syntax-rule (mk-failure0 fr code)
(lambda ()
(gp-unwind fr)
(code)))
(let ((fr (gp-unwind fr)))
(code))))
......@@ -507,11 +536,15 @@
(define (gp-cp+ . l) (apply gp-cp++ #f l))
(define *gp-cp* (make-fluid gp-cp+))
(define (gp-scm+ x s) (gp-cp++ #t x s))
(define (gp-scm-unpin x s) (gp-cp++ #t x '() s #t))
(define gp-cp++
(case-lambda
((scm? x s )
(gp-cp++ scm? x '() s))
((scm? x l s)
(gp-cp++ scm? x l s))
((scm? x l s)
(gp-cp++ scm? x l s #f))
((scm? x l s unpin?)
(define vs (gp->scm- l s))
(define tr (make-hash-table))
(define datas '())
......@@ -538,7 +571,7 @@
(lp (gp-cdr x s))))
((gp-var? x s)
(if (memq x vs)
(if (or (memq x vs) scm?)
#t
(if (not (hashq-ref tr x #f))
(hashq-set! tr x (gp-make-var)))))
......@@ -586,7 +619,9 @@
((gp-var? x s)
(if scm?
x
(begin
(when unpin? (gp-mark-permanent x))
x)
(if (memq x vs)
x
(hashq-ref tr x 'BUG))))
......@@ -702,3 +737,7 @@
(unw fr)))
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