kanren.test passes, not readoned_schemer.test

parent 6b915157
......@@ -33,7 +33,7 @@
(define (interleave sin p cc as)
(with-guarded-states guard-set! ((l '()) (r '()))
(let ((s (gp-store-state)))
(let ((s (gp-store-state sin)))
(define fail
(lambda ()
(let loop ((ll l) (rr r))
......@@ -45,8 +45,8 @@
(guard-set! (cdr ll) rr)
(thunk))))))
(define (mk-cont p)
(let ((state (gp-store-state)))
(define (mk-cont p s)
(let ((state (gp-store-state s)))
(lambda ()
(gp-restore-wind state)
(p))))
......@@ -58,7 +58,7 @@
(a sin
fail
(lambda (ss p2)
(guard-set! l (cons (mk-cont p2) r))
(guard-set! l (cons (mk-cont p2 ss) r))
(cc ss fail)))))
as)
'())
......@@ -66,7 +66,7 @@
(define (interleave-union sin p cc as)
(with-guarded-states guard-set! ((l '()) (r '()) (gs '()) (gr '()))
(let ((s (gp-store-state)))
(let ((s (gp-store-state sin)))
(define fail
(lambda ()
(let loop ((ll l) (rr r) (ggs gs) (ggr gr))
......@@ -78,8 +78,8 @@
(guard-set! (cdr ll) rr (cdr ggs) ggr)
(thunk))))))
(define (mk-cont p)
(let ((state (gp-store-state)))
(define (mk-cont p s)
(let ((state (gp-store-state s)))
(lambda ()
(gp-restore-wind state)
(p))))
......@@ -101,11 +101,11 @@
(check (cdr ggs)))
(lambda (sss p)
(gp-unwind fr)
(guard-set! l (cons (mk-cont p2) r)
(guard-set! l (cons (mk-cont p2 ss) r)
gs (cons a gr))
(fail))))
(begin
(guard-set! l (cons (mk-cont p2) r)
(guard-set! l (cons (mk-cont p2 ss) r)
gs (cons a gr))
(cc ss fail))))))))
as)
......@@ -150,8 +150,8 @@ and-interleave
(guard-set! (cdr ll) rr)
(thunk))))))
(define (mk-cont p)
(let ((state (gp-store-state)))
(define (mk-cont p s)
(let ((state (gp-store-state s)))
(lambda ()
(gp-restore-wind state)
(p))))
......@@ -161,15 +161,15 @@ and-interleave
((g2)
(g1 sin fail
(lambda (ss p2)
(guard-set! l (cons (mk-cont p2) r))
(guard-set! l (cons (mk-cont p2 ss) r))
(g2 ss fail
(lambda (sss p3)
(guard-set! l (cons (mk-cont p3) r))
(guard-set! l (cons (mk-cont p3 sss) r))
(cc sss fail))))))
((g2 . gs)
(g1 sin fail
(lambda (ss p2)
(guard-set! l (cons (mk-cont p2) r))
(guard-set! l (cons (mk-cont p2 ss) r))
(loop ss p2 g2 gs))))))))
......@@ -250,18 +250,18 @@ and-interleave
#'ss)))))))))))
(define-syntax-rule (cont-set! g p)
(define-syntax-rule (cont-set! g p sin)
(let ((cont #f))
(set! g (lambda () (cont)))
(set! cont (let ((s (gp-store-state)))
(set! cont (let ((s (gp-store-state sin)))
(lambda ()
(gp-restore-wind s)
(p))))))
(define-syntax-rule (cont2-set! g p)
(define-syntax-rule (cont2-set! g p sin)
(let ((cont #f))
(set! g (lambda (s p cc) (cont)))
(set! cont (let ((s (gp-store-state)))
(set! cont (let ((s (gp-store-state sin)))
(lambda ()
(gp-restore-wind s)
(p))))))
......@@ -292,7 +292,7 @@ and-interleave
(let ((fr (gp-newframe s)))
(g s p
(lambda (ss pp)
(cont-set! gg pp)
(cont-set! gg pp ss)
(set! vv (gp->scm v.s ss)) ...
(gp-unwind fr)
(zip-aux (s p fr) ((vvs ...) ...) ((vs.s ...) ...)
......@@ -309,7 +309,7 @@ and-interleave
((_ (s p fr) ((vv ...) . vvs) ((v ...) . vs) (g . gs) code)
(g s p
(lambda (ss pp)
(cont2-set! g pp)
(cont2-set! g pp ss)
(set! vv (gp->scm v ss)) ...
(gp-unwind fr)
(zip-aux (s p fr) vvs vs gs code))))
......
......@@ -55,12 +55,12 @@
(define-syntax let-lv
(syntax-rules ()
((_ (id ...) body)
(let ((id (gp-var!)) ...) body))))
(let ((id (gp-var! *current-stack*)) ...) body))))
(define-syntax extend-relation-with-recur-limit
(syntax-rules ()
((_ limit ids rel ...)
(let ((*counter* (gp-var!)))
(let ((*counter* (gp-var! *current-stack*)))
(lambda ids
(let ((gl (any (rel . ids) ...)))
(lambda (s p cc)
......@@ -78,7 +78,7 @@
(lambda (x)
(syntax-case x ()
((_ . l) #'(error "_ cannot be infunction possition"))
(_ #'(gp-var!)))))
(_ #'(gp-var! *current-stack*)))))
;;The following is a direct translation of kanren.ss
(define-syntax id-memv??
......@@ -357,7 +357,7 @@
(lambda (s p cc)
(let*-and (p) ((s (gp-unify! gvo term s)) ...)
(let ((var0 (if (eq? var0 _)
(gp-var!)
(gp-var! *current-stack*)
var0)) ...)
(gl s p cc))))))))
......@@ -443,7 +443,7 @@
(define-syntax solve
(syntax-rules ()
((solve n vs g ...)
(begin (gp-clear)
(begin (gp-clear *current-stack*)
(with-fluids
((*gp-var-tr* 'v.))
(<run> n vs (g) ...))))))
......
......@@ -11,15 +11,15 @@
let<> <or-i> <or-union> <stall> <continue> <take>
<state-ref> <state-set!> <lv*> <clear>
<and-i> and-interleave interleave tr
<letg> <set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip>)
<letg> <set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip> <cons>)
(re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
(define-syntax S (lambda (x) #'#f))
(define-syntax-rule (<scm> x) (gp->scm x S))
(define-syntax S (lambda (x) (error "S should be bound by fluid-let")))
(define-syntax-rule (<scm> x) (gp->scm x S))
(define-syntax-rule (<cons> x y) (gp-cons! x y S))
(define *cc* (gp-make-fluid #f))
(define *cc* (gp-make-fluid #f *current-stack*))
(define (<stall> s p cc)
(set! *cc* (cons s (cons p cc)))
......@@ -37,15 +37,15 @@
((cdr *cc*) n)
'cannot-continue-and-take-n)))))
(define (make-empty-s) (gp-newframe #f))
(define (make-empty-s) *current-stack*)
(define-syntax <eval>
(syntax-rules ()
((_ (v ...) code fini cc)
(let ((v (gp-var!)) ...)
(let ((v (gp-var! *current-stack*)) ...)
(let ((fi fini)
(c cc)
(s (make-empty-s)))
(s *current-stack*))
(parse<> (fi s fi c)
code))))))
......@@ -65,7 +65,7 @@
(cons (loop x) (loop l)))
(x
(if (gp-var? x s)
(let* ((m (gp-var-number (gp-lookup x s)))
(let* ((m (gp-var-number (gp-lookup x s) s))
(r (assoc m a)))
(if r
(cdr r)
......@@ -80,9 +80,9 @@
(define-syntax <run>
(syntax-rules (*)
((_ (v) code ...)
(let ((fr (gp-newframe #f)))
(let ((fr (gp-newframe *current-stack*)))
(if *kanren-assq*
(gp-logical++))
(gp-logical++ fr))
(with-guarded-states ret-set! ((ret '()))
(<eval> (v)
(<and> code ...)
......@@ -94,9 +94,9 @@
(p))))))
((_ (v ...) code ...)
(let ((fr (gp-newframe #f)))
(let ((fr (gp-newframe *current-stack*)))
(if *kanren-assq*
(gp-logical++))
(gp-logical++ fr))
(with-guarded-states ret-set! ((ret '()))
(<eval> (v ...)
(<and> code ...)
......@@ -113,9 +113,9 @@
((_ * . l) (<run> . l))
((_ m (v) code ...)
(let ((fr (gp-newframe #f)))
(let ((fr (gp-newframe *current-stack*)))
(if *kanren-assq*
(gp-logical++))
(gp-logical++ fr))
(with-guarded-states n-ret-set! ((n m) (ret '()))
(<eval> (v)
(<and> code ...)
......@@ -144,9 +144,9 @@
((_ m (v ...) code ...)
(let ((fr (gp-newframe #f)))
(let ((fr (gp-newframe *current-stack*)))
(if *kanren-assq*
(gp-logical++))
(gp-logical++ fr))
(with-guarded-states n-ret-set! ((n m) (ret '()))
(<eval> (v ...)
(<and> code ...)
......@@ -344,7 +344,7 @@
(define-guile-log <var>
(syntax-rules ()
((_ (cut s p cc) (v ...) code ...)
(let ((v (gp-var!)) ...)
(let ((v (gp-var! s)) ...)
(parse<> (cut s p cc) (<and> code ...))))))
(define-guile-log <let>
......@@ -495,7 +495,7 @@
(let ((cc (lambda (s p) #t))
(p (lambda () #f)))
(gp-clear)
(gp-clear *current-stack*)
(let ((s (make-empty-s)))
(<with-guile-log> (s p cc)
(<and> code ...)))))))
......@@ -782,19 +782,10 @@
;; This is code that allow to store a state
(define (<state-ref>)
(let ((ret (cons (gp-store-state)
(begin
(gp-swap-to-b)
(gp-store-state)))))
(gp-swap-to-a)
ret))
(gp-store-state *current-stack*))
(define (<state-set!> state)
(gp-restore-state (car state))
(gp-swap-to-b)
(gp-restore-state (cdr state))
(gp-swap-to-a)
(if #f #f))
(gp-restore-state state))
(define-guile-log <lv*>
(syntax-rules ()
......@@ -806,11 +797,7 @@
(parse<> meta (<and> code ...)))))
(define (<clear>)
(gp-swap-to-b)
(gp-clear)
(gp-swap-to-a)
(gp-clear))
(gp-clear *current-stack*))
(log-code-macro '<fail>)
......@@ -62,6 +62,8 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_
gp->gp_si = gp->gp_stack;
gp->gp_ci = gp->gp_cstack + 1;
gp->gp_cstack[0] = GP_UNREF(gp->gp_stack);
gp->gp_nns = gp->gp_stack + gp->gp_ns - 10;
gp->gp_nnc = gp->gp_cstack + gp->gp_nc - 10;
......
......@@ -123,10 +123,12 @@ static inline int gp_do_cons(SCM item, int state, SCM *old)
case gp_redo:
*old = SCM_CDR(*old);
}
gp_debug0("a call tag\n");
if(scm_is_false(SCM_CDR(item)))
scm_call_1(SCM_CAR(item),SCM_BOOL_F);
else
scm_call_0(SCM_CDR(item));
gp_debug0("called\n");
return state;
}
......@@ -169,7 +171,7 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
SCM *i, *ci_old, *id;
int state = 0;
DB(printf("unwind>\n");fflush(stdout));
DB(printf("unwind> %x %x\n",ci - gp->gp_cstack, gp->gp_ci - gp->gp_cstack);fflush(stdout));
ci_old = gp->gp_ci;
gp->gp_ci = ci;
......@@ -209,18 +211,22 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
id[1] = SCM_UNBOUND;
}
gp_debug1("last routines %x\n",gp->gp_ci - gp->gp_cstack);
if(state)
switch(state)
{
case gp_store:
gp_debug0("gp_store\n");
if(gp->gp_ci == gp->gp_cstack)
{
SCM_SETCDR(old,SCM_EOL);
gp_debug0("return\n");
return;
}
if(SCM_CONSP(gp->gp_ci[-1]))
{
gp_debug0("a cons\n");
SCM q = SCM_CAR(gp->gp_ci[-1]);
if(SCM_I_INUMP(q))
{
......@@ -228,21 +234,29 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
{
case gp_save_tag:
SCM_SETCDR(old,gp->gp_ci[-1]);
gp_debug0("return\n");
return;
case gp_redo_tag:
SCM_SETCDR(old,SCM_CADR(gp->gp_ci[-1]));
gp_debug0("return\n");
return;
}
}
}
gp_debug0("store / no cons\n");
gp->gp_ci[-1] = scm_cons(SCM_PACK(gp_save_tag),gp->gp_ci[-1]);
SCM_SETCDR(old,gp->gp_ci[-1]);
gp_debug0("return\n");
return;
case gp_redo:
gp_debug0("gp_redo\n");
if(gp->gp_ci == gp->gp_cstack)
return;
{
gp_debug0("return\n");
return;
}
if(SCM_CONSP(gp->gp_ci[-1]))
{
......@@ -253,14 +267,17 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
{
case gp_save_tag:
SCM_SETCDR(old,gp->gp_ci[-1]);
gp_debug0("return\n");
return;
case gp_redo_tag:
SCM_SETCDR(old,SCM_CADR(gp->gp_ci[-1]));
gp_debug0("return\n");
return;
}
}
}
gp_debug0("last linkage\n");
gp->gp_ci[-1] = scm_cons(SCM_PACK(gp_redo_tag),
scm_cons(SCM_CDR(old), gp->gp_ci[-1]));
}
......@@ -270,6 +287,7 @@ static inline void gp_unwind(SCM fr)
{
struct gp_stack *gp = get_gp(fr);
gp_debug0("<unwind>\n");
fr = SCM_CADR(fr);
SCM *ci,*si;
......@@ -286,6 +304,7 @@ static inline void gp_unwind(SCM fr)
si = gp->gp_si;
}
gp_unwind0(ci,si,gp);
gp_debug0("leaving unwind\n");
}
......@@ -305,7 +324,7 @@ SCM_DEFINE(gp_get_stack, "gp-get-stack", 1, 0, 0, (SCM s),
struct gp_stack *gp = get_gp(s);
SCM* i;
SCM ret = SCM_EOL;
for(i = gp->gp_cstack; i < gp->gp_ci; i++)
for(i = gp->gp_cstack + 1; i < gp->gp_ci; i++)
{
ret = scm_cons(*i,ret);
}
......@@ -321,7 +340,8 @@ static inline SCM gp_store_state(struct gp_stack *gp)
{
return scm_cons(SCM_I_MAKINUM(gp->_logical_),
scm_cons(PTR2NUM(gp->gp_si),
scm_cons(SCM_I_MAKINUM(0), SCM_EOL)));
scm_cons(SCM_I_MAKINUM(0)
, SCM_EOL)));
}
data = gp->gp_ci[-1];
......
......@@ -957,6 +957,7 @@ SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
#define FUNC_NAME s_gp_clear
{
struct gp_stack *gp = get_gp(s);
gp_debug0("clear\n");
gp->_logical_ = 0;
gp->gp_ci_h = (SCM *) 0;
gp_unwind0(gp->gp_cstack + 1,gp->gp_stack, gp);
......@@ -1150,7 +1151,7 @@ SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s),
{
if(GP_CONS(y))
{
return SCM_BOOL_T;
return s;
}
}
......
......@@ -74,7 +74,7 @@
(do-setup)
(gp-jumpframe-end x))
(define (glup x) (gp-lookup x *current-stack*))
(define gp-logical-var? gp?)
......@@ -114,6 +114,7 @@
(gp-fluid-set! *store-id* 0 *current-stack*)
(define (glup x) (gp-lookup x *current-stack*))
(define-syntax mk-guard
(lambda (x)
......@@ -157,7 +158,8 @@
(begin (set! s ss) ...)))))))
(set! s so) ...))))
;;The second argument is not used here
#f))))))))
#f
*current-stack*))))))))
(define-syntax with-guarded-states
(lambda (x)
......@@ -172,7 +174,8 @@
(push-setup
(lambda ()
(set! done #f))))
(lambda () (set! fr #f)))
(lambda () (set! fr #f))
*current-stack*)
(let () code ...)))))))
(define-syntax with-guarded-globals
......@@ -187,10 +190,10 @@
(define gp-make-fluid
(case-lambda
(() (old))
((x) (let ((ret (old)))
(gp-fluid-set! ret x)
ret))))
((s) (old s))
((x s) (let ((ret (old s)))
(gp-fluid-set! ret x s)
ret))))
(use-modules (srfi srfi-11))
......@@ -344,8 +347,7 @@
(define-syntax umatch***+
(syntax-rules (+)
((_ a b c (#f . l))
(let ((s #f))
(umatch***+ a b c (s . l))))
(error (format #f "umatch: #f in state position: ~a" '(a b c))))
((_ (code ...) () () (s n t _ _))
(let ((s (gp-newframe s)))
......@@ -380,9 +382,9 @@
(set! *wind* #t)
(set! *setup* #f)
(gp-restore-state-raw x)
(gp-jumpframe-start)
(gp-jumpframe-start (cdr x))
(do-setup)
(gp-jumpframe-end))
(gp-jumpframe-end (cdr x)))
(define (gp-restore-state x)
(set! *wind* #f)
......
......@@ -25,7 +25,7 @@
(syntax-rules ()
((_ title x y)
(begin
(gp-clear)
(gp-clear *current-stack*)
(with-test-prefix "start"
(pass-if (format #f "~a" 'x)
(equal? x y)))))))
......
......@@ -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 (<cons> Q SafeQs) Qs))))
('() (<=> SafeQs Qs))
( _ <fail>)))
......@@ -43,9 +43,9 @@
(queens 10 Q)))
(define (f-or)
(<run> (q)
(<or> (<=> 1 q)
(<=> 2 q))))
(<run> * (q)
(<or> (<=> 1 q)
(<=> 2 q))))
(define (f-or-2)
(<run> 2 (q)
......
......@@ -15,7 +15,7 @@
(define (translate x) x)
#;
(define (check? x y)
(let ((ret (translate x)))
(format #t "check> ~a == ~a~%" ret y)
......@@ -23,11 +23,12 @@
(equal? ret y)))
#;
(define-syntax check?
(syntax-rules ()
((_ x y)
(begin
(gp-clear)
(<clear>)
(pass-if (format #f "~a" 'x)
(equal? x y))))))
......@@ -172,7 +173,7 @@
((<=> 'oil x) <cc>)
(<fail>)))
'(olive))
(gp-clear)
(<clear>)
(check?
(<run> * (x)
......
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