logical.c added

parent df73682c
/*
This define the logical variables
*/
int _logical_ = 0;
SCM make_logical()
{
SCM ret;
SCM_NEWSMOB(ret,GP_MK_FRAME_UNBD(gp_type),(void *)0);
return ret
}
SCM logical_lookup(SCM x SCM s)
{
SCM l = s;
if(!GP(x))
return x;
retry:
if(SCM_CONSP(l))
{
SCM car = SCM_CAR(l);
if(SCM_CONSP(car))
{
if(scm_is_eq(SCM_CAR(car),x))
{
x = SCM_CDR(car);
if(!GP(x))
return x;
l = s;
goto retry;
}
else
{
l = SCM_CDR(l);
goto retry;
}
}
else
scm_misc_error("logical_lookup","malformed assoc",SCM_EOL);
}
return x;
}
SCM logical_add(SCM x, SCM v, SCM s)
{
return scm_cons(SCM_CAR(s),scm_cons(scm_cons(x,v),SCM_CDR(s)));
}
SCM_DEFINE(gp_logical_incr, "gp-logic++", 0, 0, 0, (),
"increase logic indicator")
#define FUNC_NAME s_gp_logical_incr
{
_logical_ ++;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_logical_decr, "gp-logic--", 0, 0, 0, (),
"increase logic indicator")
#define FUNC_NAME s_gp_logical_incr
{
_logical_ --;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......@@ -278,6 +278,8 @@ static inline void gp_unwind0(SCM *ci, SCM *si)
static inline void gp_unwind(SCM fr)
{
fr = SCM_CAR(fr);
SCM *ci,*si;
if(SCM_CONSP(fr))
{
......@@ -350,8 +352,12 @@ static inline SCM gp_store_state()
gp_ci[-1] = head;
}
return scm_cons(PTR2NUM(gp_si),
scm_cons(SCM_I_MAKINUM(gp_ci - gp_cstack), head));
return scm_cons(scm_cons(SCM_I_MAKINUM(_logical_),
PTR2NUM(gp_ci_h))
scm_cons(PTR2NUM(gp_si),
scm_cons(SCM_I_MAKINUM(gp_ci - gp_cstack)
, head)));
}
......@@ -529,6 +535,10 @@ static void gp_restore_state(SCM data)
gp_debug0("to restore\n");
_logical_ = SCM_I_INUM(SCM_CAAR(data));
gp_ci_h = NUM2PTR(SCM_CDAR(data));
data = SCM_CDR(data);
if(SCM_CONSP(data))
{
si = NUM2PTR(SCM_CAR(data));
......
This diff is collapsed.
......@@ -56,13 +56,26 @@
(gp-module-init)
;; assq kind of base structure
(define (mk-logical) (vector 'logical))
(define (logical? x)
(and (vector? x) (vectror-ref x 0) 'logical))
(define *gp?* #t)
(define glup gp-lookup)
(define (gp-lookup x s)
(glup x))
(define gscm gp->scm)
(define (gp->scm x s)
(gscm x))
(define gset! gp-set!)
(define (gp-set! x v s)
(gset! x v))
(gset! x v)
s)
(define gvar? gp-var?)
(define (gp-var? x s)
......@@ -82,21 +95,19 @@
(do-setup))
(define (gp-logical-var? x)
(gvar? x))
(define glup gp-lookup)
(define (gp-lookup x s)
(glup x))
(or (gp? x) (logical? x)))
(define gpun! gp-unify!)
(define (gp-unify! x y s)
(if (gpun! x y) s #f))
(define gpunr! gp-unify-raw!)
(define (gp-unify-raw! x y s) (if (gpunr! x y) s #f))
(define (gp-unify-raw! x y s)
(if (gpunr! x y) s #f))
(define gpmun! gp-m-unify!)
(define (gp-m-unify! x y s) (if (gpmun! x y) s #f))
(define (gp-m-unify! x y s)
(if (gpmun! x y) s #f))
(define gpnull! gp-null!?)
(define (gp-null!? 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