added another stack to be able to allocate closures from the stack and still...

added another stack to be able to allocate closures from the stack and still be able to store the state e.g. push the closures to the heap, einstein example works
parent ea18d8fd
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
(define-module (ice-9 match-phd-lookup) (define-module (ice-9 match-phd-lookup)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:export (match-define match-let* match-let match-letrec match-lambda* #:export (match-define match-let* match-let match-letrec match-lambda*
match-lambda match make-phd-matcher)) match-lambda match make-phd-matcher))
...@@ -291,14 +292,13 @@ ...@@ -291,14 +292,13 @@
(define-syntax match-three* (define-syntax match-three*
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null? id) rr)) s v (p) g+s sk fk i) ((match-two (abs ((car cdr pair? null? id) rr)) s v (p) g+s sk fk i)
(let ((s (pair? v s))) (let-values (((w cd s) (pair? v s)))
(if s (if s
(let ((s (null? (cdr v s) s))) (let ((s (null? cd s)))
(if s (if s
(let ((w (car v s))) (match-one (abs ((car cdr pair? null? id) rr)) s w p
(match-one (abs ((car cdr pair? null? id) rr)) s w p ((car w)
((car w) (set-car! w)) sk fk i)
(set-car! w)) sk fk i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))) (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk)))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk)))) (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
...@@ -310,14 +310,13 @@ ...@@ -310,14 +310,13 @@
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (p . q) ((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (p . q)
g+s sk fk i) g+s sk fk i)
(let ((s (pair? v s))) (let-values (((w x s) (pair? v s)))
(if s (if s
(let ((w (car v s)) (x (cdr v s))) (match-one (abs ((car cdr pair? null? equal? id) pp)) s w p
(match-one (abs ((car cdr pair? null? equal? id) pp)) s w p ((car ww) (set-car! ww))
((car ww) (set-car! ww)) (match-one s x q ((cdr ww) (set-cdr! ww)) sk fk)
(match-one s x q ((cdr ww) (set-cdr! ww)) sk fk) fk
fk i)
i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk)))) (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
((match-two abs s v #(p ...) g+s . x) ((match-two abs s v #(p ...) g+s . x)
......
...@@ -17,7 +17,8 @@ ...@@ -17,7 +17,8 @@
gp-make-stack gp-make-stack
gp-pair!? gp-null!? gp-null? gp-pair!? gp-null!? gp-null?
gp-jumpframe-start gp-jumpframe-end gp? gp-jumpframe-start gp-jumpframe-end gp?
gp-module-init)) gp-module-init
-gp-member -gp-right-of))
...@@ -46,6 +47,13 @@ ...@@ -46,6 +47,13 @@
(define-inlinable (gp-m-unify! x y s) (define-inlinable (gp-m-unify! x y s)
(fast-call-3 2 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 1 arg
(fast-call-set! gp-jumpframe-start 1 2) (fast-call-set! gp-jumpframe-start 1 2)
(define-inlinable (gp-jumpframe-start s) (define-inlinable (gp-jumpframe-start s)
...@@ -63,6 +71,10 @@ ...@@ -63,6 +71,10 @@
(define-inlinable (gp-newframe s) (define-inlinable (gp-newframe s)
(fast-call-1 5 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 2 arg
(fast-call-set! gp-lookup 2 0) (fast-call-set! gp-lookup 2 0)
...@@ -89,10 +101,25 @@ ...@@ -89,10 +101,25 @@
(define-inlinable (gp-car x s) (define-inlinable (gp-car x s)
(fast-call-2 5 x s)) (fast-call-2 5 x s))
(fast-call-set! gp-cdr 2 6) (fast-call-set! gp-cdr 2 6)
(define-inlinable (gp-cdr x s) (define-inlinable (gp-cdr x s)
(fast-call-2 6 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)
(gp-set-closure-tag tag))
(define -gp-member (gp-make-member))
(define -gp-right-of (gp-make-right-of))
(define-module (logic guile-log examples einstein) (define-module (logic guile-log examples einstein)
#:use-module (srfi srfi-11)
#:use-module (logic guile-log) #:use-module (logic guile-log)
#:use-module (logic guile-log umatch) #:use-module (logic guile-log umatch)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
...@@ -6,11 +7,22 @@ ...@@ -6,11 +7,22 @@
;(use-modules (language prolog kanren)) ;(use-modules (language prolog kanren))
(<define> (memb x l) (define memb gp-member)
(<match> () (l)
((,x . l) <cc>) #;(define (memb s p cc x l)
((_ . l) (<cut> (memb x l))) (let ((f (gp-newframe s)))
(_ <fail>))) (letrec ((next (lambda (l)
(let loop ((l l))
(gp-unwind f)
(let-values (((a as s) (gp-fpair!? l s)))
(if s
(let ((s (gp-unify-raw! a x s)))
(if s
(cc s (lambda () (next as)))
(loop as)))
(p)))))))
(next l))))
#; #;
(<define> (on-right i j l) (<define> (on-right i j l)
...@@ -21,26 +33,43 @@ ...@@ -21,26 +33,43 @@
(_ <fail>))) (_ <fail>)))
(define (on-right s p cc i j l) (define on-right gp-right-of)
#;(define (on-right s p cc i j l)
(let ((f (gp-newframe s))) (let ((f (gp-newframe s)))
(let loop ((l l)) (letrec ((next (lambda (l)
(gp-unwind f) (let loop ((l l))
(let ((s (gp-pair!? l f))) (gp-unwind f)
(if s (let-values (((ii ll s) (gp-fpair!? l f)))
(let ((ii (gp-car l s)) (if s
(ll (gp-cdr l s))) (let-values (((jj kk s) (gp-fpair!? ll s)))
(let ((s (gp-pair!? ll s))) (if s
(if s (let ((s (gp-unify-raw! ii i s)))
(let ((jj (gp-car ll s))) (if s
(let ((s (gp-unify-raw! ii i s))) (let ((s (gp-unify-raw! jj j s)))
(if s (if s
(let ((s (gp-unify-raw! jj j s))) (cc s (lambda () (next ll)))
(if s (loop ll)))
(cc s (lambda () (loop ll))) (loop ll)))
(loop ll))) (p)))
(loop ll)))) (p))))))
(p))))
(p)))))) (loop (lambda (l)
(gp-unwind f)
(let-values (((ii ll s) (gp-fpair!? l f)))
(if s
(let-values (((jj kk s) (gp-fpair!? ll s)))
(if s
(let ((s (gp-unify-raw! ii i s)))
(if s
(let ((s (gp-unify-raw! jj j s)))
(if s
(cc s (lambda () (next ll)))
(loop ll)))
(loop ll)))
(p)))
(p))))))
(loop l))))
(<define> (next-to item1 item2 rest) (<define> (next-to item1 item2 rest)
...@@ -54,24 +83,66 @@ ...@@ -54,24 +83,66 @@
((x . l) #'((gp-var! *current-stack*) . l)) ((x . l) #'((gp-var! *current-stack*) . l))
(_ #'(gp-var! *current-stack*))))) (_ #'(gp-var! *current-stack*)))))
(define a1 #f)
(define a2 #f)
(define a3 #f)
(define a4a #f)
(define a4b #f)
(define a5 #f)
(define a6 #f)
(define a7 #f)
(define a8a #f)
(define a8b #f)
(define a9 #f)
(define a10a #f)
(define a10b #f)
(define a11a #f)
(define a11b #f)
(define a12 #f)
(define a13 #f)
(define a14a #f)
(define a14b #f)
(define a15 #f)
(<define> (einstein h) (<define> (einstein h)
(<code>
(set! a1 `(brit ,__ ,__ ,__ red))
(set! a2 `(swede dog ,__ ,__ ,__ ))
(set! a3 `(dane ,__ ,__ tea ,__ ))
(set! a4a `(,__ ,__ ,__ ,__ green))
(set! a4b `(,__ ,__ ,__ ,__ white))
(set! a5 `(,__ ,__ ,__ cofee green))
(set! a6 `(,__ bird pallmall ,__ ,__))
(set! a7 `(,__ ,__ dunhill ,__ yellow))
(set! a8a `(,__ ,__ dunhill ,__ ,__))
(set! a8b `(,__ horse ,__ ,__ ,__))
(set! a9 `(,__ ,__ ,__ milk ,__))
(set! a10a `(,__ ,__ marlboro ,__ ,__))
(set! a10b `(,__ cat ,__ ,__ ,__))
(set! a11a `(,__ ,__ marlboro ,__ ,__))
(set! a11b `(,__ ,__ ,__ water ,__))
(set! a12 `(,__ ,__ winfield beer ,__))
(set! a13 `(german ,__ rothmans ,__ ,__))
(set! a14a `(norwegian ,__ ,__ ,__ ,__))
(set! a14b `(,__ ,__ ,__ ,__ blue))
(set! a15 `(,__ fish ,__ ,__ ,__)))
(<and> (<and>
(<=> h ,`((norwegian ,__ ,__ ,__ ,__) ,__ (,__ ,__ ,__ milk ,__) ,__ ,__)) (<=> h ,`((norwegian ,__ ,__ ,__ ,__) ,__ (,__ ,__ ,__ milk ,__) ,__ ,__))
(memb `(brit ,__ ,__ ,__ red) h) (memb a1 h)
(memb `(swede dog ,__ ,__ ,__ ) h) (memb a2 h)
(memb `(dane ,__ ,__ tea ,__ ) h) (memb a3 h)
(on-right `(,__ ,__ ,__ ,__ green) `(,__ ,__ ,__ ,__ white) h) (on-right a4a a4b h)
(memb `(,__ ,__ ,__ cofee green) h) (memb a5 h)
(memb `(,__ bird pallmall ,__ ,__) h) (memb a6 h)
(memb `(,__ ,__ dunhill ,__ yellow) h) (memb a7 h)
(next-to `(,__ ,__ dunhill ,__ ,__) `(,__ horse ,__ ,__ ,__) h) (next-to a8a a8b h)
(memb `(,__ ,__ ,__ milk ,__) h) (memb a9 h)
(next-to `(,__ ,__ marlboro ,__ ,__) `(,__ cat ,__ ,__ ,__) h) (next-to a10a a10b h)
(next-to `(,__ ,__ marlboro ,__ ,__) `(,__ ,__ ,__ water ,__) h) (next-to a11a a11b h)
(memb `(,__ ,__ winfield beer ,__) h) (memb a12 h)
(memb `(german ,__ rothmans ,__ ,__) h) (memb a13 h)
(next-to `(norwegian ,__ ,__ ,__ ,__) `(,__ ,__ ,__ ,__ blue) h) (next-to a14a a14b h)
(memb `(,__ fish ,__ ,__ ,__) h) (memb a15 h)
)) ))
......
(define-module (logic guile-log examples queens)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (srfi srfi-11)
#:export (run))
(<define> (queens N Qs)
(<var> (Ns)
(<and> (range-list 1 N Ns)
(queens3 Ns '() Qs))))
(<define> (queens3 UnplacedQs SafeQs Qs)
(<match> () (UnplacedQs)
( _ (<var> (Q UnplacedQs1)
(<and> (selectq Q UnplacedQs UnplacedQs1)
(<not> (attack Q SafeQs))
(queens3 UnplacedQs1 (<cons> Q SafeQs) Qs))))
('() (<=> SafeQs Qs))
( _ <fail>)))
(<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)))
(if s
(let ((x (gp->scm x s))
(y (gp->scm ca s)))
(let ((f (gp-newframe s)))
(if (or (eq? x (+ y n)) (eq? x (- y n)))
(cc f (lambda ()
(gp-unwind f)
(attack3 f p cc x (+ n 1) cd)))
(attack3 f p cc x (+ n 1) cd))))
(p))))
#;
(<define> (attack3 X N V)
(<match> () (V)
((Y . _) (<when> (or (eq? (<scm> X) (+ (<scm> Y) N))
(eq? (<scm> X) (- (<scm> Y) N)))))
((_ . Y) (attack3 X (+ N 1) Y))
(_ <fail>)))
(<define> (range-list M N U)
(<match> () (U)
((,M) (<when> (>= M N) <cut>))
((,M . L) (range-list (+ M 1) N L))
(_ <fail>)))
(<define> (selectq X U Xs)
(<match> () (U Xs)
((,X . ,Xs) _ <cc>)
(( Y . Ys) ( Y . Zs) (selectq X Ys Zs))
(_ _ <fail>)))
(define (f)
(<run> * (Q)
(queens 10 Q)))
(define (run n)
(if (= n 0)
#t
(begin
(f)
(run (- n 1)))))
...@@ -2,9 +2,9 @@ LIBS = `pkg-config --libs guile-2.0` ...@@ -2,9 +2,9 @@ LIBS = `pkg-config --libs guile-2.0`
CFLAGS = `pkg-config --cflags guile-2.0` 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 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) -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 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 guile-snarf -o unify.x $(CFLAGS) unify.c
...@@ -11,17 +11,23 @@ struct gp_stack ...@@ -11,17 +11,23 @@ struct gp_stack
int _logical_; int _logical_;
int gp_ncs;
SCM *gp_cons_stack;
int gp_nc; int gp_nc;
SCM *gp_cstack; SCM *gp_cstack;
int gp_ns; int gp_ns;
SCM *gp_stack; SCM *gp_stack;
SCM* gp_cs;
SCM* gp_si; SCM* gp_si;
SCM* gp_ci; SCM* gp_ci;
SCM *gp_nnc; SCM *gp_nnc;
SCM *gp_nns; SCM *gp_nns;
SCM *gp_nncs;
SCM *gp_ci_h; SCM *gp_ci_h;
SCM *gp_ci_q; SCM *gp_ci_q;
}; };
...@@ -39,8 +45,10 @@ static inline struct gp_stack *get_gp(SCM s) ...@@ -39,8 +45,10 @@ static inline struct gp_stack *get_gp(SCM s)
return (struct gp_stack *)0; return (struct gp_stack *)0;
} }
static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_stack **ggp) static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, struct gp_stack **ggp)
{ {
int i,ii;
*ggp = *ggp =
(struct gp_stack *) scm_gc_malloc_pointerless(sizeof(struct gp_stack),"struct gp_stack"); (struct gp_stack *) scm_gc_malloc_pointerless(sizeof(struct gp_stack),"struct gp_stack");
...@@ -60,14 +68,24 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_ ...@@ -60,14 +68,24 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_
scm_gc_protect_object(GP_UNREF(gp->gp_stack)); scm_gc_protect_object(GP_UNREF(gp->gp_stack));
gp->gp_nc = nc; gp->gp_cons_stack =
gp->gp_ns = ns; (SCM *) scm_gc_malloc(sizeof(SCM) * ncs,"gp->gp_stack");
if(!gp->gp_cons_stack) goto error4;
scm_gc_protect_object(GP_UNREF(gp->gp_cons_stack));
gp->gp_nc = nc;
gp->gp_ns = ns;
gp->gp_ncs = ncs;
gp->gp_si = gp->gp_stack; gp->gp_si = gp->gp_stack;
gp->gp_ci = gp->gp_cstack; gp->gp_ci = gp->gp_cstack;
gp->gp_cs = gp->gp_cons_stack;
gp->gp_nns = gp->gp_stack + gp->gp_ns - 10; gp->gp_nns = gp->gp_stack + gp->gp_ns - 10;
gp->gp_nnc = gp->gp_cstack + gp->gp_nc - 10; gp->gp_nnc = gp->gp_cstack + gp->gp_nc - 10;
gp->gp_nncs = gp->gp_cons_stack + gp->gp_ncs - 10;
gp->_logical_ = 0; gp->_logical_ = 0;
gp->gp_ci_h = (SCM *) 0; gp->gp_ci_h = (SCM *) 0;
...@@ -77,11 +95,25 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_ ...@@ -77,11 +95,25 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_
SCM ret; SCM ret;
SCM_NEWSMOB(ret, gp_stack_type, (void*)0); SCM_NEWSMOB(ret, gp_stack_type, (void*)0);
GP_GETREF(ret)[1] = GP_UNREF((SCM *) gp); GP_GETREF(ret)[1] = GP_UNREF((SCM *) gp);
for(i = 0; i < gp->gp_ncs; i++)
{
gp->gp_cs[i] = SCM_BOOL_F;
}
for(i = 0; i < gp->gp_ncs && i < 10000; i++)
{
gp->gp_cs[i] = scm_cons(SCM_BOOL_F,SCM_BOOL_F);
}
scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack)); scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack));
scm_gc_unprotect_object(GP_UNREF(gp->gp_stack)); scm_gc_unprotect_object(GP_UNREF(gp->gp_stack));
scm_gc_unprotect_object(GP_UNREF(gp->gp_cons_stack));
return GP_GETREF(ret); return GP_GETREF(ret);
error4:
scm_gc_unprotect_object(GP_UNREF(gp->gp_stack));
error3: error3:
scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack)); scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack));
...@@ -96,18 +128,26 @@ static SCM gp_stack_mark(SCM obj) ...@@ -96,18 +128,26 @@ static SCM gp_stack_mark(SCM obj)
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(obj); struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(obj);
int i; int i;
printf("stack mark\n");
scm_gc_mark(GP_UNREF(gp->gp_cstack)); scm_gc_mark(GP_UNREF(gp->gp_cstack));
scm_gc_mark(GP_UNREF(gp->gp_stack)); scm_gc_mark(GP_UNREF(gp->gp_stack));
scm_gc_mark(GP_UNREF(gp->gp_cons_stack));
for(i=0;i < gp->gp_ci - gp->gp_cstack; i++) for(i=0;i < gp->gp_ci - gp->gp_cstack; i++)
{ {
scm_gc_mark(gp->gp_cstack[i]); scm_gc_mark(gp->gp_cstack[i]);
} }
for(i=0;i < gp->gp_si - gp->gp_stack; i+=2) for(i=0;i < gp->gp_nncs - gp->gp_cons_stack; i++)
{
scm_gc_mark(gp->gp_cons_stack[i]);
}
for(i=0;i < gp->gp_si - gp->gp_stack; i++)
{ {
if(GP_VAL(&(gp->gp_stack[i]))) // if(GP_VAL(&(gp->gp_stack[i])))
scm_gc_mark(gp->gp_stack[i+1]); scm_gc_mark(gp->gp_stack[i+1]);
} }
return SCM_BOOL_T; return SCM_BOOL_T;
...@@ -126,3 +166,67 @@ static void gp_module_stack_init() ...@@ -126,3 +166,67 @@ static void gp_module_stack_init()
scm_set_smob_mark(gp_stack_type, gp_stack_mark); scm_set_smob_mark(gp_stack_type, gp_stack_mark);
scm_set_smob_print(gp_stack_type,gp_stack_printer); scm_set_smob_print(gp_stack_type,gp_stack_printer);
} }
static inline void gp_alloc_cons(struct gp_stack *gp, int n)
{
int i;
if(!(gp->gp_cs + n <= gp->gp_nncs)) goto error;
if(!SCM_CONSP(gp->gp_cs[n-1])) goto allocate;
return;
allocate:
for(i=0;i < 10000 && gp->gp_cs+i < gp->gp_nncs;i++)
{
if(!SCM_CONSP(gp->gp_cs[i]))
gp->gp_cs[i] = scm_cons(SCM_BOOL_F,SCM_BOOL_F);
}
return;
error:
scm_misc_error("gp_alloc_cons","cons stack is full",SCM_EOL);
return;
}
static inline SCM gpa_cons(SCM x, SCM y, struct gp_stack *gp)
{
SCM r = gp->gp_cs[0];
gp->gp_cs++;
SCM_SETCAR(r,x);
SCM_SETCDR(r,y);
return r;
}
static inline SCM* gp_alloc_data(int n, struct gp_stack *gp)
{
int i;
if(!(gp->gp_si + n <= gp->gp_nns)) goto error;
SCM * ret = gp->gp_si;
gp->gp_si += n;
return ret;
error:
scm_misc_error("gp_alloc_data","data stack is full",SCM_EOL);
return;
}
static inline SCM gp_make_vector(int n, struct gp_stack *gp)
{
SCM *vec = gp_alloc_data(n + SCM_I_VECTOR_HEADER_SIZE,gp);
((scm_t_bits *) vec)[0] = (n << 8) | scm_tc7_vector;
((scm_t_bits *) vec)[1] = 0;
return PTR2SCM(vec);
}
static inline SCM gp_make_closure(int n, SCM **closure, SCM s)
{
struct gp_stack *gp = get_gp(s);
SCM vec = gp_make_vector(n,gp);
*closure = SCM_I_VECTOR_WELTS(vec);
gp_alloc_cons(gp,1);
return gpa_cons(closure_tag, vec, gp);
}
This diff is collapsed.
...@@ -27,6 +27,8 @@ scm_t_bits gp_type; ...@@ -27,6 +27,8 @@ scm_t_bits gp_type;
SCM gp_wind; SCM gp_wind;
SCM gp_setup; SCM gp_setup;
SCM closure_tag;
#define gp_format0(str) \ #define gp_format0(str) \
scm_simple_format(SCM_BOOL_T, \ scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \ scm_from_locale_string(str), \
...@@ -424,9 +426,16 @@ static inline SCM * gp_lookup2(SCM *id, SCM s) ...@@ -424,9 +426,16 @@ static inline SCM * gp_lookup2(SCM *id, SCM s)
return id; return id;
} }
/*
This routine stores information about stacks on the
control stack and returns a structure representing the
computational state. This routine makes sure to allocate
datstructures before storing the state in them meaning that
after an unwind the unwind information can be reused.
*/
static inline SCM gp_newframe(SCM s) static inline SCM gp_newframe(SCM s)
{ {
SCM sss = s; SCM sss = s,ret;
s = SCM_CDR(s); s = SCM_CDR(s);
struct gp_stack *gp = get_gp(sss); struct gp_stack *gp = get_gp(sss);
...@@ -434,24 +443,45 @@ static inline SCM gp_newframe(SCM s) ...@@ -434,24 +443,45 @@ static inline SCM gp_newframe(SCM s)
if(SCM_CONSP(s)) if(SCM_CONSP(s))
{ {
SCM fr = SCM_CAR(s); SCM fr = SCM_CAR(s);
SCM *ci = NUM2PTR(SCM_CAR(fr)); SCM *ci = NUM2PTR(fr);
SCM *si = NUM2PTR(SCM_CDR(fr)); SCM *si = NUM2PTR(ci[-2]);
SCM *cs = NUM2PTR(ci[-1]);
if((gp->gp_ci == ci || (ci == gp->gp_ci_h && gp->gp_ci == gp->gp_ci_q)) if((gp->gp_ci == ci