added dynamic features

parent ca8e7abc
......@@ -38,7 +38,7 @@ SOURCES = \
logic/guile-log/postpone.scm \
logic/guile-log/util.scm \
logic/guile-log/functional-database.scm \
logic/guile-log/iso-prolog.scm \
logic/guile-log/dynamic-features.scm \
logic/guile-log/prolog/pre.scm \
logic/guile-log/prolog/error.scm \
logic/guile-log/prolog/symbols.scm \
......@@ -61,6 +61,7 @@ SOURCES = \
logic/guile-log/prolog/functions.scm \
logic/guile-log/prolog/util.scm \
logic/guile-log/prolog/conversion.scm \
logic/guile-log/iso-prolog.scm \
logic/guile-log/guile-prolog/continuations.scm \
logic/guile-log/guile-prolog/hash.scm \
logic/guile-log/guile-prolog/interleave.scm
......
This diff is collapsed.
......@@ -20,9 +20,7 @@
<clause-dynamic>
<retract-dynamic>
<retract-all-dynamic>
<lambda-dyn>
<with-dynamic-functions>
<guard-dynamic-functions>))
<lambda-dyn>))
#|
Action dynlist array indexed
......@@ -672,35 +670,3 @@ add/run * vlist *
(if s #t #f))))
#f)))
;; Border saving
(<define> (<with-dynamic-functions> . fs)
(<code>
(for-each
(lambda (f)
(let ((F (case-lambda
(() (dynamic-env-ref f))
((x)
(dynamic-env-set! f x)
(dynamic-truncate! f)))))
(gp-fluid-set F (dynamic-env-ref f))))
fs)))
;; Unclear how to introduce this function,
;; Right now in (<or-i> A B) the state of the dynamic variable
;; is the same for each restart in A.
(<define> (<guard-dynamic-functions> . fs)
(<code>
(for-each
(lambda (f)
(let* ((s (dynamic-env-ref f))
(F (case-lambda
(()
(let ((ret (dynamic-env-ref f)))
(if (not (eq? s ret))
(dynamic-refcount++ f)
ret)))
((x)
(dynamic-env-set! f x)
(dynamic-truncate! f)))))
(gp-undo-safe-variable-guard F #t S)))
fs)))
......@@ -26,7 +26,8 @@ structure and this tree and unwind/rewind them in a logically more correct way.
//RGUARD
#define D_RGUARD_VAR 1
#define D_RGUARD_K 2
#define D_NRGUARD 3
#define D_OLD_K 3
#define D_NRGUARD 4
//LGUARD
#define D_LGUARD_VAR 1
......@@ -36,7 +37,8 @@ structure and this tree and unwind/rewind them in a logically more correct way.
//FLUID
#define D_FLUID_VAR 1
#define D_FLUID_VAL 2
#define D_NFLUID 3
//#define D_OLD_K 3
#define D_NFLUID 4
#define GET_ENV(h) SCM_I_VECTOR_WELTS(SCM_VARIABLE_REF(h));
#define OLD(h) h[4];
......@@ -102,6 +104,18 @@ SCM_DEFINE(undo_safe_variable_guard, "gp-undo-safe-variable-guard", 3, 0, 0,
SCM rguard_skip(SCM rguard, SCM var);
SCM get_l_k_part(SCM k, SCM guards)
{
SCM pt;
for(pt = guard; SCM_CONSP(pt); pt = SCM_CDR(pt))
{
SCM *v = SCM_I_VECTOR_WELTS(SCM_CAR(pt));
if(v[D_LGUARD_VAR] == k)
return v[D_OLD_K];
}
return SCM_BOOL_F;
}
SCM_DEFINE(undo_safe_variable_rguard, "gp-undo-safe-variable-rguard", 3, 0, 0,
(SCM var, SCM kind, SCM s),
"")
......@@ -118,10 +132,22 @@ SCM_DEFINE(undo_safe_variable_rguard, "gp-undo-safe-variable-rguard", 3, 0, 0,
vnew[D_ID] = SCM_PACK(D_RGUARD);
vnew[D_RGUARD_K] = kind;
vnew[D_RGUARD_VAR] = var;
vnew[D_OLD_K] = SCM_BOOL_F;
gp->dynstack = scm_cons(vnew_, gp->dynstack);
gp->dynstack_length += 4;
if(scm_is_true(scm_procedure_p (var)))
{
SCM old_kind = get_l_k_part(var, gp->dynstack);
if(old_kind != SCM_BOOL_F)
{
gp->rguards =
scm_cons(scm_cons(var,old_kind), rguard_skip(gp->rguards, var));
return SCM_UNSPECIFIED;
}
}
gp->rguards = rguard_skip(gp->rguards, var);
return SCM_UNSPECIFIED;
......@@ -134,6 +160,27 @@ SCM_DEFINE(undo_safe_variable_rguard, "gp-undo-safe-variable-rguard", 3, 0, 0,
}
#undef FUNC_NAME
SCM has_old_ref(SCM k, SCM guards)
{
int found = 0;
SCM pt;
for(pt = guard; SCM_CONSP(pt); pt = SCM_CDR(pt))
if(SCM_CAAR(pt) == k)
return 1;
return 0;
}
SCM get_oldkind(SCM k, SCM guards)
{
SCM pt;
for(pt = guard; SCM_CONSP(pt); pt = SCM_CDR(pt))
{
if(SCM_CAAR(pt) == k)
return SCM_CDAR(pt);
}
return SCM_BOOL_F;
}
SCM_DEFINE(undo_safe_variable_lguard, "gp-undo-safe-variable-lguard", 3, 0, 0,
(SCM var, SCM kind, SCM s),
"")
......@@ -151,7 +198,18 @@ SCM_DEFINE(undo_safe_variable_lguard, "gp-undo-safe-variable-lguard", 3, 0, 0,
vnew[D_ID] = SCM_PACK(D_LGUARD);
vnew[D_LGUARD_K] = kind;
vnew[D_LGUARD_VAR] = var;
vnew[D_OLD_K] = SCM_BOOL_F;
if(scm_is_true(scm_procedure_p (var)) && has_old_ref(var, gp->rguards))
{
SCM old_kind = get_oldkind(var, gp->rguards);
if(old_kind != kind)
{
vnew[D_OLD_K] = old_kind;
}
else
return SCM_UNSPECIFY;
}
gp->dynstack = scm_cons(vnew_, gp->dynstack);
gp->dynstack_length += 4;
......@@ -360,6 +418,7 @@ SCM rguard_skip(SCM rguard, SCM var)
}
return rguard;
}
void eval_rguard(SCM guard, SCM K)
{
SCM* v = SCM_I_VECTOR_WELTS(guard);
......@@ -444,14 +503,22 @@ SCM manage_dyn_wind(SCM obj, SCM K, SCM *rguard) {
if(id == D_LGUARD)
{
*rguard = scm_cons(scm_cons(v[D_LGUARD_VAR], v[D_LGUARD_K]), *rguard);
if(v[D_OLD_K] == SCM_BOOL_F)
*rguard = scm_cons(scm_cons(v[D_LGUARD_VAR], v[D_LGUARD_K]), *rguard);
else
*rguard = scm_cons(scm_cons(v[D_LGUARD_VAR], v[D_LGUARD_K]),
rguard_skip(*rguard, var));
return obj;
}
if(id == D_RGUARD)
{
SCM var = v[D_RGUARD_VAR];
*rguard = rguard_skip(*rguard, var);
if(v[D_OLD_K] == SCM_BOOL_F)
*rguard = rguard_skip(*rguard, var);
else
*rguard = scm_cons(scm_cons(v[D_RGUARD_VAR], v[D_OLD_K]),
rguard_skip(*rguard, var));
return obj;
}
......@@ -534,7 +601,10 @@ SCM unwind_dynstack_it(SCM pp, SCM *rguard)
if(id == D_LGUARD)
{
SCM var = v[D_LGUARD_VAR];
*rguard = rguard_skip(*rguard, var);
if(v[D_OLD_K] == SCM_BOL_F)
*rguard = rguard_skip(*rguard, var);
else
*rguard = scm_cons(scm_cons(var,v[D_OLD_K]),rguard_skip(*rguard, var));
gp_debug0(" unwind DLGUARD\n");
return pp;
......@@ -543,8 +613,14 @@ SCM unwind_dynstack_it(SCM pp, SCM *rguard)
if(id == D_RGUARD)
{
gp_debug0(" unwind DRGUARD\n");
*rguard = scm_cons(scm_cons(v[D_RGUARD_VAR], v[D_RGUARD_K]),
*rguard);
if(v[D_OLD_K] == SCM_BOOL_F)
*rguard = scm_cons(scm_cons(v[D_RGUARD_VAR], v[D_RGUARD_K]),
*rguard);
else
*rguard = scm_cons(scm_cons(v[D_RGUARD_VAR], v[D_RGUARD_K]),
rguard_skip(*rguard, var));
return pp;
}
......
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