all non assq tests sucesses

parent 755c9426
(define-module (logic guile-log code-load)
#:use-module (system vm vm)
#:export (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind gp-var!
gp->scm gp-print
gp-budy gp-m-unify!
gp-lookup
gp-var? gp-cons! gp-set!
gp-var-number gp-print-stack
gp-car gp-cdr gp-pair?
gp-car gp-cdr gp-pair? gp-pair* gp-pair- gp-pair+
gp-store-state gp-restore-state
gp-make-fluid gp-fluid-set! gp-fluid-ref
gp-dynwind
......@@ -18,7 +19,8 @@
gp-pair!? gp-null!? gp-null?
gp-jumpframe-start gp-jumpframe-end gp?
gp-module-init
-gp-member -gp-right-of))
gp-setup-set! gp-wind-set! gp-setup-ref gp-wind-ref
-gp-member -gp-right-of -next-to -einstein))
......@@ -29,97 +31,55 @@
(error "libguile-unify.so is not present, did you forget to make it?")))
;; fast call 3 args
(fast-call-set! gp-unify! 3 0)
(define -gp-unify! gp-unify!)
(define-inlinable (gp-unify! x y s)
(fast-call-3 0 x y s))
(fast-call-set! gp-unify-raw! 3 1)
(define -gp-unify-raw! gp-unify-raw!)
(define-inlinable (gp-unify-raw! x y s)
(fast-call-3 1 x y s))
(fast-call-set! gp-m-unify! 3 2)
(define -gp-m-unify! gp-m-unify!)
(define-inlinable (gp-m-unify! x y s)
(fast-call-3 2 x y s))
#|
(fast-call-set! -gp-member 3 3)
(define --gp-member -gp-member)
(define-inlinable (-gp-member x l s)
(fast-call-3 3 x l s))
|#
;; fast call 1 arg
(fast-call-set! gp-jumpframe-start 1 2)
(define-inlinable (gp-jumpframe-start s)
(fast-call-1 2 s))
(fast-call-set! gp-jumpframe-end 1 3)
(define-inlinable (gp-jumpframe-end s)
(fast-call-1 3 s))
(fast-call-set! gp-unwind 1 4)
(define-inlinable (gp-unwind s)
(fast-call-1 4 s))
(fast-call-set! gp-newframe 1 5)
(define-inlinable (gp-newframe s)
(fast-call-1 5 s))
(fast-call-set! gp-var! 1 6)
(define-inlinable (gp-var! s)
(fast-call-1 6 s))
;; fast call 2 arg
(fast-call-set! gp-lookup 2 0)
(define-inlinable (gp-lookup x s)
(fast-call-2 0 x s))
(fast-call-set! gp-pair!? 2 1)
(define-inlinable (gp-pair!? x s)
(fast-call-2 1 x s))
(fast-call-set! gp-pair? 2 2)
(define-inlinable (gp-pair? x s)
(fast-call-2 2 x s))
(fast-call-set! gp-null!? 2 3)
(define-inlinable (gp-null!? x s)
(fast-call-2 3 x s))
(fast-call-set! gp-null? 2 4)
(define-inlinable (gp-null? x s)
(fast-call-2 4 x s))
(fast-call-set! gp-car 2 5)
(define-inlinable (gp-car x s)
(fast-call-2 5 x s))
(fast-call-set! gp-cdr 2 6)
(define-inlinable (gp-cdr x s)
(fast-call-2 6 x s))
(fast-call-set! gp->scm 2 7)
(define-inlinable (gp->scm x s)
(fast-call-2 7 x s))
;; fast call 4 args
#|
(fast-call-set! -gp-right-of 4 0)
(define-inlinable (-gp-right-of x y l s)
(fast-call-4 0 x y l s))
|#
(let ((tag (cons 'the 'closure-tag)))
(set-c-closure-tag tag)
(let ((tag (the-c-closure-tag)))
(set-car! tag 'c)
(set-cdr! tag 'tag)
(gp-set-closure-tag tag))
(define -gp-member (gp-make-member))
(define -gp-right-of (gp-make-right-of))
(define wrap #f)
(define-syntax-rule (define3 nm r)
(define nm (let ((rr r))
(if wrap
(lambda (x y z) (rr x y z))
rr))))
(define-syntax-rule (define2 nm r)
(define nm (let ((rr r))
(if wrap
(lambda (x y) (rr x y))
rr))))
(define-syntax-rule (define1 nm r)
(define nm (let ((rr r))
(if wrap
(lambda (x) (rr x))
r))))
(define api (gp-make-log-api))
(define3 gp-unify! (cdr (assq 'gp-unify! api)))
(define3 gp-unify-raw! (cdr (assq 'gp-unify-raw! api)))
(define3 gp-m-unify (cdr (assq 'gp-m-unify api)))
(define -gp-member (cdr (assq 'gp-member api)))
(define -gp-right-of (cdr (assq 'gp-right api)))
(define -next-to (cdr (assq 'gp-next-to api)))
(define1 gp-jumpframe-start
(cdr (assq 'gp-jumpframe-start api)))
(define1 gp-jumpframe-end
(cdr (assq 'gp-jumpframe-end api)))
(define1 gp-unwind (cdr (assq 'gp-unwind api)))
(define1 gp-newframe (cdr (assq 'gp-newframe api)))
(define1 gp-var! (cdr (assq 'gp-var! api)))
(define2 gp-lookup (cdr (assq 'gp-lookup api)))
(define2 gp-pair!? (cdr (assq 'gp-pair!? api)))
(define2 gp-pair? (cdr (assq 'gp-pair? api)))
(define2 gp-null!? (cdr (assq 'gp-null!? api)))
(define2 gp-null? (cdr (assq 'gp-null? api)))
(define2 gp-car (cdr (assq 'gp-car api)))
(define2 gp-cdr (cdr (assq 'gp-cdr api)))
(define2 gp->scm (cdr (assq 'gp->scm api)))
(define2 gp-pair* (cdr (assq 'gp-pair* api)))
(define2 gp-pair- (cdr (assq 'gp-pair- api)))
(define2 gp-pair+ (cdr (assq 'gp-pair+ api)))
(define -einstein #f)
......@@ -71,8 +71,9 @@
(p))))))
(loop l))))
(<define> (next-to item1 item2 rest)
(define next-to gp-next-to)
#;(<define> (next-to item1 item2 rest)
(<or> (on-right item1 item2 rest)
(on-right item2 item1 rest)))
......@@ -150,5 +151,7 @@
(let loop ((n N))
(cond
((zero? n) 'done)
(else (pretty-print (<run> 1 (h) (einstein h)))
(loop (- n 1))))))
(else
(gp-clear *current-stack*)
(pretty-print (<run> 1 (h) (einstein h)))
(loop (- n 1))))))
......@@ -21,8 +21,9 @@
(<define> (attack X Xs) (attack3 X 1 Xs))
(define (attack3 s p cc x n v)
(let-values (((ca cd s) (gp-fpair!? v s)))
(let-values (((ca cd s) (gp-pair+ v s)))
(if s
(let ((x (gp->scm x s))
(y (gp->scm ca s)))
......@@ -37,8 +38,9 @@
#;
(<define> (attack3 X N V)
(<match> () (V)
((Y . _) (<when> (or (eq? (<scm> X) (+ (<scm> Y) N))
(eq? (<scm> X) (- (<scm> Y) N)))))
((Y . _) (<and>
(<when> (or (eq? (<scm> X) (+ (<scm> Y) N))
(eq? (<scm> X) (- (<scm> Y) N))))))
((_ . Y) (attack3 X (+ N 1) Y))
(_ <fail>)))
......
......@@ -3,7 +3,7 @@ CFLAGS = `pkg-config --cflags guile-2.0`
libguile-unify.so : unify.h unify.c unify-undo-redo.c logical.c unify.x state.c functional-tree.c util.c
gcc $(LIBS) $(CFLAGS) -O3 -shared -o libguile-unify.so -fPIC unify.c
gcc $(LIBS) $(CFLAGS) -O3 -shared -o libguile-unify.so -fPIC unify.c
unify.x : unify.h unify.c unify-undo-redo.c logical.c state.c functional-tree.c util.c
guile-snarf -o unify.x $(CFLAGS) unify.c
......
This source diff could not be displayed because it is too large. You can view the blob instead.
(use-modules (language clambda clambda))
(use-modules (language clambda scm))
(use-modules (language clambda logic))
(use-modules (language clambda fmt))
(define gp-unify! (mk-var 'coid '_gp_unify #f 'no-gensym))
(define gp-unify-raw! (mk-var 'coid '_gp_unify_raw #f 'no-gensym))
(define gp-m-unify (mk-var 'coid '_gp_m_unify #f 'no-gensym))
(define gp-jumpframe-start (mk-var 'coid '_gp_jumpframe_start #f
'no-gensym))
(define gp-jumpframe-end (mk-var 'coid '_gp_jumpframe_end #f
'no-gensym))
(define gp-unwind (mk-var 'coid '_gp_unwind #f 'no-gensym))
(define gp-newframe (mk-var 'coid '_gp_newframe #f 'no-gensym))
(define gp-var! (mk-var 'coid '_gp_mkvar #f 'no-gensym))
(define gp-lookup (mk-var 'coid '_gp_lookup #f 'no-gensym))
(define gp-pair!? (mk-var 'coid '_gp_pair_bang #f 'no-gensym))
(define gp-pair? (mk-var 'coid '_gp_pair #f 'no-gensym))
(define gp-null!? (mk-var 'coid '_gp_null_bang #f 'no-gensym))
(define gp-null? (mk-var 'coid '_gp_null #f 'no-gensym))
(define gp-car (mk-var 'coid '_gp_car #f 'no-gensym))
(define gp-cdr (mk-var 'coid '_gp_cdr #f 'no-gensym))
(define gp->scm (mk-var 'coid '_gp_2_scm #f 'no-gensym))
(define gp-pair+ (mk-var 'coid '_gp_pair_plus #f 'no-gensym))
(define gp-pair* (mk-var 'coid '_gp_pair_star #f 'no-gensym))
(define gp-pair- (mk-var 'coid '_gp_pair_minus #f 'no-gensym))
(init-clambda-scm)
(auto-defs)
(<global> SCM member (<scm> #f))
(<global> SCM right (<scm> #f))
(<global> SCM einstein (<scm> #f))
(<global> SCM next-to (<scm> #f))
(<global> SCM ein2 (<scm> #f))
(<global> SCM a1 (<scm> #f))
(<global> SCM a2 (<scm> #f))
(<global> SCM a3 (<scm> #f))
(<global> SCM a4a (<scm> #f))
(<global> SCM a4b (<scm> #f))
(<global> SCM a5 (<scm> #f))
(<global> SCM a6 (<scm> #f))
(<global> SCM a7 (<scm> #f))
(<global> SCM a8a (<scm> #f))
(<global> SCM a8b (<scm> #f))
(<global> SCM a9 (<scm> #f))
(<global> SCM a10a (<scm> #f))
(<global> SCM a10b (<scm> #f))
(<global> SCM a11a (<scm> #f))
(<global> SCM a11b (<scm> #f))
(<global> SCM a12 (<scm> #f))
(<global> SCM a13 (<scm> #f))
(<global> SCM a14a (<scm> #f))
(<global> SCM a14b (<scm> #f))
(<global> SCM a15 (<scm> #f))
(:define: (memb x l)
(:match: (l)
((x . _) (:cc:))
((_ . ,l) (:call: member x l))))
(:define: (righ x y l)
(:match: (l)
((x y . _) (:cc:))
((_ . ,l) (:call: right x y l))))
(:define: (nextto item1 item2 rest)
(:or: (:call: right item1 item2 rest)
(:call: right item2 item1 rest)))
#|
(:define: (ein h)
(:code:
(<=> a1 (<scm> `(brit ,_ ,_ ,_ red)))
(<=> a2 (<scm> `(swede dog ,_ ,_ ,_ )))
(<=> a3 (<scm> `(dane ,_ ,_ tea ,_ )))
(<=> a4a (<scm> `(,_ ,_ ,_ ,_ green)))
(<=> a4b (<scm> `(,_ ,_ ,_ ,_ white)))
(<=> a5 (<scm> `(,_ ,_ ,_ cofee green)))
(<=> a6 (<scm> `(,_ bird pallmall ,_ ,_)))
(<=> a7 (<scm> `(,_ ,_ dunhill ,_ yellow)))
(<=> a8a (<scm> `(,_ ,_ dunhill ,_ ,_)))
(<=> a8b (<scm> `(,_ horse ,_ ,_ ,_)))
(<=> a9 (<scm> `(,_ ,_ ,_ milk ,_)))
(<=> a10a (<scm> `(,_ ,_ marlboro ,_ ,_)))
(<=> a10b (<scm> `(,_ cat ,_ ,_ ,_)))
(<=> a11a (<scm> `(,_ ,_ marlboro ,_ ,_)))
(<=> a11b (<scm> `(,_ ,_ ,_ water ,_)))
(<=> a12 (<scm> `(,_ ,_ winfield beer ,_)))
(<=> a13 (<scm> `(german ,_ rothmans ,_ ,_)))
(<=> a14a (<scm> `(norwegian ,_ ,_ ,_ ,_)))
(<=> a14b (<scm> `(,_ ,_ ,_ ,_ blue)))
(<=> a15 (<scm> `(,_ fish ,_ ,_ ,_))))
(:=: h (<scm> `((norwegian ,_ ,_ ,_ ,_) ,_ (,_ ,_ ,_ milk ,_) ,_ ,_)))
(:call: member a1 h)
(:call: member a2 h)
(:call: member a3 h)
(:call: right a4a a4b h)
(:call: member a5 h)
(:call: member a6 h)
(:call: ein2 h))
(:define: (e2 h)
(:call: member a7 h)
(:call: next-to a8a a8b h)
(:call: member a9 h)
(:call: next-to a10a a10b h)
(:call: next-to a11a a11b h)
(:call: member a12 h)
(:call: member a13 h)
(:call: next-to a14a a14b h)
(:call: member a15 h)
)
|#
(<define> void init-einstein ()
(<=> next-to (yield-log nextto))
(<=> member (yield-log memb))
(<=> right (yield-log righ))
;(<=> einstein (yield-log ein))
;(<=> ein2 (yield-log e2))
(auto-inits))
(<define> SCM make-api-list ()
(<call> init-einstein)
(<scm> `((gp-unify! . ,(yield-log gp-unify!))
(gp-unify-raw! . ,(yield-log gp-unify-raw!))
(gp-m-unify . ,(yield-log gp-m-unify))
(gp-member . ,member)
(gp-right . ,right)
(gp-next-to . ,next-to)
(gp-jumpframe-start . ,(yield-log gp-jumpframe-start))
(gp-jumpframe-end . ,(yield-log gp-jumpframe-end))
(gp-unwind . ,(yield-log gp-unwind))
(gp-newframe . ,(yield-log gp-newframe))
(gp-var! . ,(yield-log gp-var!))
(gp-lookup . ,(yield-log gp-lookup))
(gp-pair!? . ,(yield-log gp-pair!?))
(gp-pair? . ,(yield-log gp-pair?))
(gp-null!? . ,(yield-log gp-null!?))
(gp-null? . ,(yield-log gp-null?))
(gp-car . ,(yield-log gp-car))
(gp-cdr . ,(yield-log gp-cdr))
(gp->scm . ,(yield-log gp->scm))
(gp-pair* . ,(yield-log gp-pair*))
(gp-pair- . ,(yield-log gp-pair-))
(gp-pair+ . ,(yield-log gp-pair+))
)))
(clambda->c "einstein.c")
......@@ -124,7 +124,7 @@ inline SCM logical_lookup2(SCM x, SCM l)
return x;
}
SCM logical_add(SCM x, SCM v, SCM s)
SCM inline logical_add(SCM x, SCM v, SCM l)
{
/*
{
......@@ -137,17 +137,7 @@ SCM logical_add(SCM x, SCM v, SCM s)
}
*/
if(!SCM_CONSP(s)) goto er;
SCM ss = SCM_CDR(s);
if(!SCM_CONSP(ss)) goto er;
SCM l = SCM_CDR(ss);
return scm_cons(SCM_CAR(s),
scm_cons(SCM_CAR(ss),scm_cons(scm_cons(x,v),l)));
er:
scm_misc_error("logical_add","malformed s",SCM_EOL);
return SCM_BOOL_F;
return scm_cons(scm_cons(x,v),l);
}
......
......@@ -30,6 +30,9 @@ struct gp_stack
SCM *gp_ci_h;
SCM *gp_ci_q;
SCM gp_wind;
SCM gp_setup;
};
static inline struct gp_stack *get_gp(SCM s)
......@@ -128,7 +131,7 @@ static SCM gp_stack_mark(SCM obj)
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(obj);
int i;
printf("stack mark\n");
//printf("stack mark\n");
scm_gc_mark(GP_UNREF(gp->gp_cstack));
scm_gc_mark(GP_UNREF(gp->gp_stack));
......@@ -141,6 +144,8 @@ static SCM gp_stack_mark(SCM obj)
for(i=0;i < gp->gp_nncs - gp->gp_cons_stack; i++)
{
if(scm_is_false(gp->gp_cons_stack[i]))
break;
scm_gc_mark(gp->gp_cons_stack[i]);
}
......@@ -191,6 +196,12 @@ static inline SCM gpa_cons(SCM x, SCM y, struct gp_stack *gp)
{
SCM r = gp->gp_cs[0];
gp->gp_cs++;
if(!SCM_CONSP(r))
{
r = scm_cons(x,y);
gp->gp_cs[-1] = r;
return r;
}
SCM_SETCAR(r,x);
SCM_SETCDR(r,y);
return r;
......@@ -230,3 +241,10 @@ static inline SCM gp_make_closure(int n, SCM **closure, SCM s)
gp_alloc_cons(gp,1);
return gpa_cons(closure_tag, vec, gp);
}
static inline SCM gp_make_closure_heap(int n, SCM **closure)
{
SCM vec = scm_c_make_vector(n,SCM_BOOL_F);
*closure = SCM_I_VECTOR_WELTS(vec);
return scm_cons(closure_tag, vec);
}
This diff is collapsed.
This diff is collapsed.
......@@ -82,3 +82,9 @@ SCM_API SCM gp_right_of(SCM x, SCM y, SCM l, SCM s);
SCM_API SCM gp_make_member();
SCM_API SCM gp_make_right();
SCM_API SCM gp_set_closure_tag(SCM tag);
SCM_API SCM gp_make_einstein();
SCM_API SCM gp_wind_set(SCM s, SCM v);
SCM_API SCM gp_setup_set(SCM s, SCM v);
SCM_API SCM gp_wind_ref(SCM s);
SCM_API SCM gp_setup_ref(SCM s);
/*
SCM_DEFINE(gp_member, "-gp-member", 3, 0, 0,
(SCM x, SCM l, SCM s),
......@@ -30,7 +29,7 @@ SCM_DEFINE(gp_member, "-gp-member", 3, 0, 0,
goto retry;
}
*/
#define unify(x,y,s) gp_gp_unify(x,y,s);
SCM_DEFINE(gp_member, "-gp-member", 3, 0, 0,
(SCM x, SCM l, SCM s),
"the member operation for logical variables")
......@@ -43,8 +42,8 @@ SCM_DEFINE(gp_member, "-gp-member", 3, 0, 0,
a = SCM_CAR(l);
l = SCM_CDR(l);
s = gp_gp_unify(x,a,s);
if(scm_is_false(s)) goto bang_next;
s = unify(x,a,s);
if(!s) goto bang_next;
return scm_cons(s,l);
......@@ -114,14 +113,10 @@ SCM_DEFINE(gp_right_of, "-gp-right-of", 4, 0, 0,
b = SCM_CAR(ll);
vv1 = UN_GP(a);
vv2 = UN_GP(x);
s = gp_unify(vv1,vv2,0,1,s);
s = unify(a,x,s);
if(!s) goto bang_next;
vv1 = UN_GP(b);
vv2 = UN_GP(y);
s = gp_unify(vv1,vv2,0,1,s);
s = unify(b,y,s);
if(!s) goto bang_next;
return scm_cons(s,ll);
......@@ -136,12 +131,9 @@ SCM_DEFINE(gp_right_of, "-gp-right-of", 4, 0, 0,
goto retry;
}
int memb_help(SCM **spp, int nargs, const SCM *closure)
{
/*
closure[0] = memb
closure[1] = l
*/
(*spp)[-nargs + 0] = closure[0];
(*spp)[-nargs + 1] = closure[1];
......@@ -150,18 +142,10 @@ int memb_help(SCM **spp, int nargs, const SCM *closure)
return 1;
}
int memb(SCM **spp, int nargs, const SCM *closure)
int mb(SCM **spp, int nargs, const SCM *closure)
{
SCM *sp,a,s,l,pp,f;
/*
sp[0] = l
closure[4] = memb
closure[3] = x
closure[2] = cc
closure[1] = p
closure[0] = f
*/
//printf("memb\n");fflush(stdout);
......@@ -183,11 +167,12 @@ int memb(SCM **spp, int nargs, const SCM *closure)
if(scm_is_false(s)) goto retry;
//printf("memb cc\n");fflush(stdout);
pp = scm_c_make_vector(3,SCM_BOOL_F);
scm_c_vector_set_x(pp, 0, PTR2NUM(memb_help));
scm_c_vector_set_x(pp, 1, closure[4]);
scm_c_vector_set_x(pp, 2, l);
pp = scm_cons(closure_tag, pp);
SCM *p;
pp = gp_make_closure(3,&p,s);
p[0] = PTR2NUM(memb_help);
p[1] = closure[4];
p[2] = l;
sp = *spp;
sp[-nargs + 0] = closure[2];
......@@ -205,43 +190,25 @@ int memb(SCM **spp, int nargs, const SCM *closure)
return 0;
}
int member(SCM **spp, int nargs, const SCM *closure)
{
/*
/*
sp[0] = l
sp[-1] = x
sp[-2] = cc
sp[-3] = p
sp[-4] = s
sp[0] = l
closure[4] = memb
closure[3] = x
closure[2] = cc
closure[1] = p
closure[0] = f
*/
SCM *sp,f,pp,ppp;
int mbr(SCM **spp, int nargs, const SCM *closure)
{
SCM *sp,f,*pp,ppp;
//printf("member\n");fflush(stdout);
sp = *spp;
f = gp_newframe(sp[-4]);
ppp = gp_make_closure(6,&pp,sp[-4]);
pp = scm_c_make_vector(6,SCM_BOOL_F);
scm_c_vector_set_x(pp, 0, PTR2NUM(memb));
scm_c_vector_set_x(pp, 1, f);
scm_c_vector_set_x(pp, 2, sp[-3]);
scm_c_vector_set_x(pp, 3, sp[-2]);
scm_c_vector_set_x(pp, 4, sp[-1]);
ppp = scm_cons(closure_tag, pp);
scm_c_vector_set_x(pp, 5, ppp);
f = gp_newframe(sp[-4]);
pp[0] = PTR2NUM(mb);
pp[1] = f;
pp[2] = sp[-3];
pp[3] = sp[-2];
pp[4] = sp[-1];
pp[5] = ppp;
sp[-nargs + 0] = ppp;
sp[-nargs + 1] = gp_gp_lookup(sp[0],f);
......@@ -250,20 +217,11 @@ int member(SCM **spp, int nargs, const SCM *closure)
return 1;
}
int rght(SCM **spp, int nargs, const SCM *closure)
{
SCM *sp,a,b,s,l,pp,f;
/*
sp[0] = l
closure[5] = memb
closure[4] = y
closure[3] = x
closure[2] = cc
closure[1] = p
closure[0] = f
*/
//printf("rght\n");fflush(stdout);
l = (*spp)[0];
......@@ -292,13 +250,6 @@ int rght(SCM **spp, int nargs, const SCM *closure)
p[1] = closure[5];
p[2] = l;
/*
pp = scm_c_make_vector(3,SCM_BOOL_F);
scm_c_vector_set_x(pp, 0, PTR2NUM(memb_help));
scm_c_vector_set_x(pp, 1, closure[5]);
scm_c_vector_set_x(pp, 2, l);
pp = scm_cons(closure_tag, pp);
*/
sp = *spp;
sp[-nargs + 0] = closure[2];
sp[-nargs + 1] = s;
......@@ -315,28 +266,10 @@ int rght(SCM **spp, int nargs, const SCM *closure)
return 0;
}
int right(SCM **spp, int nargs, const SCM *closure)
{
/*
/*
sp[0] = l
sp[-1] = y
sp[-2] = x
sp[-3] = cc
sp[-4] = p
sp[-5] = s
sp[0] = l
closure[5] = memb
closure[4] = y
closure[3] = x
closure[2] = cc
closure[1] = p
closure[0] = f
*/
int ri(SCM **spp, int nargs, const SCM *closure)
{
SCM *sp,f,*pp,ppp;
......@@ -357,42 +290,55 @@ int right(SCM **spp, int nargs, const SCM *closure)
pp[5] = sp[-1];
pp[6] = ppp;
/*
pp = scm_c_make_vector(7,SCM_BOOL_F);
scm_c_vector_set_x(pp, 0, PTR2NUM(rght));
scm_c_vector_set_x(pp, 1, f);
scm_c_vector_set_x(pp, 2, sp[-4]);
scm_c_vector_set_x(pp, 3, sp[-3]);
scm_c_vector_set_x(pp, 4, sp[-2]);
scm_c_vector_set_x(pp, 5, sp[-1]);
ppp = scm_cons(closure_tag, pp);
scm_c_vector_set_x(pp, 6, ppp);
*/
sp[-nargs + 0] = ppp;
sp[-nargs + 1] = gp_gp_lookup(sp[0],f);
*spp = sp - nargs + 1;
return rght(spp,1,pp + 1);
}