or-i on recursive function does not blow the stack anymore

parent b798f7cb
......@@ -2,9 +2,9 @@ LIBS = `pkg-config --libs guile-2.0`
CFLAGS = `pkg-config --cflags guile-2.0`
libguile-unify.so : unify.h unify.c unify-undo-redo.c unify.x
libguile-unify.so : unify.h unify.c unify-undo-redo.c logical.c unify.x
gcc $(LIBS) $(CFLAGS) -shared -o libguile-unify.so -fPIC unify.c
unify.x : unify.h unify.c unify-undo-redo.c
unify.x : unify.h unify.c unify-undo-redo.c logical.c
guile-snarf -o unify.x $(CFLAGS) unify.c
......@@ -13,7 +13,13 @@ SCM make_logical()
SCM logical_lookup(SCM x, SCM s)
{
SCM l = SCM_CDR(s);
SCM l;
if(SCM_CONSP(s))
l = SCM_CDR(s);
else
return x;
if(!GP(x))
return x;
retry:
......
......@@ -326,8 +326,7 @@ static inline SCM gp_store_state()
if(gp_ci == gp_cstack)
{
return scm_cons(scm_cons(SCM_I_MAKINUM(_logical_),
PTR2NUM(gp_ci_h)),
return scm_cons(SCM_I_MAKINUM(_logical_),
scm_cons(PTR2NUM(gp_si),
scm_cons(SCM_I_MAKINUM(0), SCM_EOL)));
}
......@@ -354,9 +353,7 @@ static inline SCM gp_store_state()
gp_ci[-1] = head;
}
return scm_cons(scm_cons(SCM_I_MAKINUM(_logical_),
PTR2NUM(gp_ci_h)),
return scm_cons(SCM_I_MAKINUM(_logical_),
scm_cons(PTR2NUM(gp_si),
scm_cons(SCM_I_MAKINUM(gp_ci - gp_cstack)
, head)));
......@@ -537,8 +534,8 @@ 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));
_logical_ = SCM_I_INUM(SCM_CAR(data));
gp_ci_h = (SCM *) 0;
data = SCM_CDR(data);
if(SCM_CONSP(data))
......
......@@ -88,6 +88,8 @@ SCM* gp_si_b;
SCM* gp_si_a;
SCM *gp_ci_h = (SCM *) 0;
SCM *gp_ci_q = (SCM *) 0;
SCM *gp_ci;
SCM *gp_ci_a;
SCM *gp_ci_b;
......@@ -462,7 +464,8 @@ static inline SCM gp_newframe(SCM s)
SCM fr = SCM_CAR(s);
SCM *ci = NUM2PTR(SCM_CAR(fr));
SCM *si = NUM2PTR(SCM_CDR(fr));
if((gp_ci == ci || ci == gp_ci_h) && si == gp_si)
if((gp_ci == ci || (ci == gp_ci_h && gp_ci == gp_ci_q))
&& si == gp_si)
return s;
{
gp_ci_h = (SCM *) 0;
......@@ -472,10 +475,11 @@ static inline SCM gp_newframe(SCM s)
return scm_cons(cons,ss);
}
}
else
scm_misc_error("gp_newframe","wrong input format",SCM_EOL);
return s;
gp_ci_h = (SCM *) 0;
SCM cons = scm_cons(PTR2NUM(gp_ci),PTR2NUM(gp_si));
SCM ss = SCM_EOL;
return scm_cons(cons,ss);
}
#define GP_TEST_STACK if(gp_si > gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp_ns))
......@@ -592,7 +596,7 @@ static SCM smob2scm_gp(SCM *id, SCM s)
}
SCM_DEFINE( smob2scm, "gp->scm", 1, 0, 0, (SCM scm, SCM s),
SCM_DEFINE( smob2scm, "gp->scm", 2, 0, 0, (SCM scm, SCM s),
"creates a scheme representation of a gp object")
#define FUNC_NAME s_smob2scm
{
......@@ -1022,7 +1026,7 @@ SCM_DEFINE(gp_mkvar, "gp-var!", 0, 0, 0, (),
}
#undef FUNC_NAME
SCM_DEFINE(gp_varp,"gp-var?",1,0,0,(SCM x, SCM s),
SCM_DEFINE(gp_varp,"gp-var?",2,0,0,(SCM x, SCM s),
"Test for an unbound variable.")
#define FUNC_NAME s_gp_varp
{
......@@ -1103,9 +1107,17 @@ SCM_DEFINE (gp_gp_newframe, "gp-newframe",1,0,0,(SCM s),
}
#undef FUNC_NAME
SCM_DEFINE (gp_gp_jumpframe, "gp-jumpframe",0,0,0,(),
SCM_DEFINE (gp_jumpframe_end, "gp-jumpframe-end",0,0,0,(),
"Created a prolog frame to backtrack from")
#define FUNC_NAME s_gp_gp_newframe
#define FUNC_NAME s_gp_jumpframe_end
{
gp_ci_q = gp_ci;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (gp_jumpframe_start, "gp-jumpframe-start",0,0,0,(),
"Created a prolog frame to backtrack from")
#define FUNC_NAME s_gp_jumpframe_start
{
gp_ci_h = gp_ci;
return SCM_UNSPECIFIED;
......@@ -1171,8 +1183,8 @@ SCM_DEFINE(gp_cons_bang, "gp-cons!", 3, 0, 0, (SCM car, SCM cdr, SCM s),
gp_debus0("gp-cons>\n");
cons = GP_GETREF(gp_mk_cons());
DS(smob2scm(car));
DS(smob2scm(cdr));
DS(smob2scm(car, s));
DS(smob2scm(cdr, s));
if(GP(car))
{
......
......@@ -72,5 +72,7 @@ SCM_API SCM gp_dynwind(SCM in, SCM out);
//SCM_API SCM gp_copy(SCM x);
SCM_API SCM gp_gp_jumpframe_start();
SCM_API SCM gp_gp_jumpframe_end();
SCM_API SCM gp_logical_incr();
SCM_API SCM gp_logical_decr();
......@@ -57,73 +57,23 @@
(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 mk-logical gp-var!)
(define logical? gp?)
(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)
s)
(define gvar? gp-var?)
(define (gp-var? x s)
(gvar? x))
(define gpn gp-newframe)
(define (gp-newframe x)
(if (or (null? x) (pair? x))
(cons (gpn) (cdr x))
(cons (gpn) '())))
(define gpun gp-unwind)
(define (gp-unwind x)
(set! *wind* #t)
(set! *setup* #f)
(gpun (car x))
(do-setup))
(gpun x)
(gp-jumpframe-start)
(do-setup)
(gp-jumpframe-end))
(define (gp-logical-var? 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 gpmun! gp-m-unify!)
(define (gp-m-unify! x y s)
(if (gpmun! x y) s #f))
(define gpnull! gp-null!?)
(define (gp-null!? x s)
(if (gpnull! x) s #f))
(define gpnull gp-null?)
(define (gp-null? x s)
(if (gpnull x) s #f))
(define gppair! gp-pair!?)
(define (gp-pair!? x s)
(if (gppair! x) s #f))
(define gppair gp-pair?)
(define (gp-pair? x s)
(if (gppair x) s #f))
(define (glup x) (gp-lookup x '()))
(define gp-logical-var? gp?)
(define-syntax **um** (syntax-rules () ((_ . l) (umatch . l))))
(define dyn gp-dynwind)
......@@ -240,7 +190,7 @@
(define (get-line x u)
(if (gp? x)
(let ((x (glup x)))
(if (and (gp? x) (gppair x))
(if (and (gp? x) (gp-pair? x '()))
(get-line (gp-cdr x) (cons (gp-car x) u))
(if (null? x)
(values (reverse u) '())
......@@ -256,7 +206,7 @@
(let ((x (glup x)))
(if (gp? x)
(if (gppair x)
(if (gp-pair x '())
(let-values (((l d) (get-line x '())))
(if (null? x)
(f l "")
......@@ -267,8 +217,8 @@
(define gp-fluid-ref
(case-lambda
((x) (glup x))
((x s) (glup x s))))
((x) (gp-lookup x '()))
((x s) (gp-lookup x s))))
(define-syntax with-gp-fluids
(syntax-rules ()
......@@ -295,7 +245,10 @@
(define (id x) x)
(define-syntax id
(syntax-rules ()
((_ x s) x)))
(define (ppair? x s)
(if (pair? x) s #f))
(define (nnull? x s)
......@@ -419,7 +372,9 @@
(set! *wind* #t)
(set! *setup* #f)
(gp-restore-state-raw x)
(do-setup))
(gp-jumpframe-start)
(do-setup)
(gp-jumpframe-end))
(define (gp-restore-state x)
(set! *wind* #f)
......
......@@ -13,7 +13,7 @@
( _ (<var> (Q UnplacedQs1)
(<and> (selectq Q UnplacedQs UnplacedQs1)
(<not> (attack Q SafeQs))
(queens3 UnplacedQs1 (gp-cons! Q SafeQs) Qs))))
(queens3 UnplacedQs1 (gp-cons! Q SafeQs '()) Qs))))
('() (<=> SafeQs Qs))
( _ <fail>)))
......
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