further bugs squached code stabalises

parent f18754f2
......@@ -204,7 +204,8 @@
(<let> ((fr (<newframe>)))
(<values> (yy zz) (copy-term-3 x))
(<values> (ww) (copy-term-2 (cons yy zz)))
(<code> (<unwind> fr))
(<code> (<unwind-tail> fr))
<cc>
(<=> (y . z) ww)))))
......@@ -215,7 +216,8 @@
(<let> ((fr (<newframe>)))
(<values> (yy zz) (duplicate-term-3 x))
(<values> (ww) (copy-term-2 (cons yy zz)))
(<code> (<unwind> fr))
(<code> (<unwind-tail> fr))
<cc>
(<=> (y . z) ww)))))
......
......@@ -318,7 +318,6 @@
((_ w) (parse<> w <cc>))
((_ (cut s p cc) a ...)
(let ((ccc (lambda (ss pp . l)
(<prune> s)
(apply cc ss p l))))
(parse<> (cut s p ccc) (<and> a ... ))))))
......
......@@ -196,7 +196,7 @@
(s2 (gp-newframe s1)))
(with-fluids ((*current-stack* s2))
(let ((ret (begin code ...)))
(gp-unwind s1)
(gp-unwind-tail s1)
ret)))))
(define* (compile stx l #:optional (name #f) (lam? #f) (closed? #f))
......@@ -287,7 +287,7 @@
(fr2 (gp-newframe fr1)))
(with-fluids ((*current-stack* fr2))
((<lambda> () #,res) fr2 (lambda () #f) (lambda x #t))
(gp-unwind fr1))))))
(gp-unwind-tail fr1))))))
(define (top x i)
(match (pp 'top x)
......
......@@ -97,9 +97,9 @@ We could make all variable references through a stack frame e.g.
(let ((xx (x b))
(yy (y b)))
(lambda (s p c cc a)
(let ((fr (gp-newframe s)))
(let ((fr (gp-newframe-choice s)))
(xx s (lambda ()
(gp-unwind fr)
(gp-unwind-tail fr)
(yy s p c cc a)) c cc a))))))
(define (if p x y)
......@@ -108,12 +108,13 @@ We could make all variable references through a stack frame e.g.
(xx (x b))
(yy (y b)))
(lambda (s p c cc a)
(let ((fr (gp-newframe s)))
(let ((fr (gp-newframe-choice s)))
(pp s (lambda ()
(gp-unwind fr)
(gp-unwind-tail fr)
(yy s p c cc a))
c
(lambda (ss pp)
(gp-prune-tail fr)
(xx ss p c cc a))))))))
|#
......
......@@ -999,7 +999,7 @@
(fformat s ",~%~a" (scm->pl S (car ts) ns q i n)))
(lp (cdr ts)))
<cc>))
(<code> (<unwind> fr))
(<code> (<unwind-tail> fr))
(<with-fail> p <cc>))))
(_
......@@ -1056,7 +1056,8 @@
(e (call-with-values
(lambda () (read-prolog-term S s (current-module)))
(lambda x x))))
(<code> (<unwind> fr))
(<code> (<unwind-tail> fr))
<cc>
(<or>
(<and> (<=> ,(list term v vn si) e) <cut>)
(<=> ,(list term v vn si) ,(list end_of_file '() '() '())))
......
......@@ -165,7 +165,7 @@ when none is available, reading FILE-NAME with READER."
(fr2 (gp-newframe fr1)))
(with-fluids ((*current-stack* fr2))
(load-in-vicinity-q #,(or dir #'(getcwd)) arg ...))
(gp-unwind fr1)))
(gp-unwind-tail fr1)))
(id
(identifier? #'id)
#`(lambda args
......
......@@ -4,7 +4,7 @@
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log functional-database)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch) #:select (gp-unwind))
#:use-module ((logic guile-log umatch) #:select (gp-unwind gp-unwind-tail))
#:use-module ((logic guile-log umatch) #:select (*current-stack* gp-var-set
gp-newframe
gp-unwind))
......@@ -592,7 +592,7 @@
(let* ((fr1 (gp-newframe (fluid-ref *current-stack*)))
(fr2 (gp-newframe fr1)))
(let ((res (with-fluids ((*current-stack* fr2)) l)))
(gp-unwind fr1)
(gp-unwind-tail fr1)
res)))
(define-syntax-rule (with-state code ...)
......@@ -800,7 +800,7 @@
(define-syntax-rule (with-s s code ...)
(let ((s (gp-newframe s)))
code ...
(gp-unwind s)))
(gp-unwind-tail s)))
(define (use-pub-ops mod s)
(with-s s
......
......@@ -226,7 +226,7 @@
(when (< x y))
(if (let* ((fr (gp-newframe S))
(ret (term0< S (lambda () #f) (lambda x #t) x y)))
(gp-unwind fr)
(gp-unwind-tail fr)
ret)
<cc>
<fail>))))
......
......@@ -5,7 +5,7 @@
#:use-module (logic guile-log vlist)
#:use-module ((logic guile-log umatch)
#:select
(*current-stack* gp-unwind gp-newframe))
(*current-stack* gp-unwind gp-unwind-tail gp-newframe))
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log dynamic-features)
#:use-module (system syntax)
......@@ -1032,7 +1032,7 @@
(var->code (<scm> l)) line)
(<ret> #f))))
u b c)))))
(gp-unwind u)
(gp-unwind-tail u)
r)))
......
......@@ -5,7 +5,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module ((logic guile-log umatch)
#:select (gp-newframe gp-unwind *current-stack*))
#:select (gp-newframe gp-unwind gp-unwind-tail *current-stack*))
#:use-module (logic guile-log prompts)
#:export (prolog-run prolog-run-* proog-run-0 var->code))
......@@ -60,7 +60,7 @@
(<lambda> (tag next l)
(<format> #t "DYNAMIC ERROR:~%=> ~a~%~%" (var->code (<scm> l)))
(<ret> (<scm> l))))))))
((@ (logic guile-log umatch) gp-unwind) fr1)))
((@ (logic guile-log umatch) gp-unwind-tail) fr1)))
(define (prolog-run-0 f . l)
......@@ -76,7 +76,8 @@
(<lambda> ()
(init-machines)
(<apply> f l)
(<code> ((@ (logic guile-log umatch) gp-unwind) fr1)))
<cc>
(<code> ((@ (logic guile-log umatch) gp-unwind-tail) fr1)))
(<lambda> (tag next l)
(<format> #t "DYNAMIC ERROR:~%=> ~a~%~%" (var->code (<scm> l)))
(<ret> (<scm> l))))))))))
......
......@@ -83,7 +83,8 @@
((fluid-ref mk-v) x xx i)
((fluid-ref mk-v) y yy j)
(<==> xx yy)
(<code> (<unwind> s)))))
<cc>
(<code> (<unwind-tail> s)))))
(define (add-var s x l)
(if (gp-attvar? x s)
......@@ -135,7 +136,7 @@
(s (<newframe>)))
((fluid-ref subs) x y l)
(when (and-map (lambda (x) (eq? x (<lookup> x))) (car l)))
(<code> (<unwind> s))
(<code> (<unwind-tail> s))
(<with-fail> p <cc>)))
......
......@@ -430,6 +430,10 @@ void gp_clean_pairs(struct gp_stack *gp)
{
ptu = gp->gp_cstack + GP_GET_VAL_VAL(pfr);
if(!scm_is_eq(*ptu,GP_GET_VAL(pfr)))
scm_misc_error("state","ci self entry is not the same~%~a",
scm_list_1(*ptu));
retry:
while(pt < ptu)
{
......@@ -523,6 +527,8 @@ gp_stack_mark0(SCM obj, int unlocked,
GC_MARK(gp->rguards);
GC_MARK(gp->handlers);
GC_MARK(GP_UNREF(gp->gp_frstack));
GC_MARK(GP_UNREF(gp->gp_cstack));
GC_MARK(GP_UNREF(gp->gp_stack));
GC_MARK(GP_UNREF(gp->gp_cons_stack));
......@@ -629,6 +635,9 @@ gp_stack_mark0(SCM obj, int unlocked,
SCM *pt;
for(pt = gp->gp_fr; pt > gp->gp_frstack + GP_FRAMESIZE; pt -= GP_FRAMESIZE)
{
if(SCM_CONSP(pt[-1]))
GC_MARK(GP_UNREF(pt[-1]));
SCM *f = GP_GETREF(GP_GET_SELF(pt));
scm_t_bits head = SCM_UNPACK(f[0]);
if(unlocked)
......@@ -644,7 +653,7 @@ gp_stack_mark0(SCM obj, int unlocked,
else
GC_MARK(GP_UNREF(f));
}
for(i=0;i < gp->gp_si - gp->gp_stack; i++)
{
SCM *pt = gp->gp_stack + i;
......
......@@ -185,11 +185,18 @@ static inline int gp_advanced_fr(SCM item, int state, SCM *old, SCM gp_unbd)
gp_handle(SCM_CDR(item), 1, gp_unbd, gp_redo);
return gp_redo;
*/
case gp_store:
SCM_SETCDR(*old, item);
case gp_store:
if(SCM_CONSP(*old))
SCM_SETCDR(*old, item);
else
scm_misc_error("unwind","a",SCM_EOL);
case 0:
*old = item;
if(!SCM_CONSP(*old))
scm_misc_error("unwind","b",SCM_EOL);
if(!SCM_CONSP(item))
scm_misc_error("unwind","c",SCM_EOL);
item = SCM_CDR(item);
SCM_SETCAR(*old, gp_handle_fr(item, 1, gp_unbd, gp_store));
SCM_SETCDR(*old, SCM_EOL);
......@@ -197,6 +204,11 @@ static inline int gp_advanced_fr(SCM item, int state, SCM *old, SCM gp_unbd)
}
case gp_redo_tag:
if(!SCM_CONSP(item))
scm_misc_error("unwind","d",SCM_EOL);
if(!SCM_CONSP(*old))
scm_misc_error("unwind","e",SCM_EOL);
item = SCM_CDR(item);
redo = SCM_CAR(item);
if(state == gp_store)
......@@ -205,6 +217,8 @@ static inline int gp_advanced_fr(SCM item, int state, SCM *old, SCM gp_unbd)
*old = redo;
return gp_redo;
default:
scm_misc_error("gp-unwind","not a correct tag ~%~a",
scm_list_1(SCM_PACK(item)));
return 0;
}
}
......@@ -412,7 +426,7 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
{
gp_debug2("fr= %d. i = %d\n",fr - gp->gp_frstack, i - fr);
// ------------------- Code for stack pointers -----------------
if(SCM_I_INUMP(*i))
if(SCM_I_INUMP(*i) || scm_is_false(*i))
{
gp_debug0("unwind a fr frame ints\n");
int j;
......@@ -423,7 +437,7 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
}
continue;
}
else
else if(SCM_CONSP(*i))
{
gp_debug0("unwind a frame cmplx\n");
......@@ -437,6 +451,8 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
i--;
}
}
else
*i = SCM_BOOL_F;
}
gp->gp_fr = fr;
......@@ -804,7 +820,15 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nfr)
ha = GP_GET_HANDLERS(fr);
dyn_n = GP_GET_DLENGTH(fr);
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr) + 1 - nfr;
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr);
if(!scm_is_eq(*ci,GP_GET_VAL(fr)))
scm_misc_error("gp-unwind","ci self entry is not the same~%~a",
scm_list_1(*ci));
ci += 1 - nfr;
si = gp->gp_stack + GP_GET_VAR(fr) - nvar;
cs = gp->gp_cons_stack + GP_GET_CONS(fr) - ncons;
......@@ -822,7 +846,7 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nfr)
gp_debug0("leaving unwind\n");
}
void inline falsify_entires(SCM *ci,struct gp_stack *gp)
void inline falsify_entries(SCM *ci,struct gp_stack *gp)
{
SCM *i = gp->gp_ci - 1;
int action = 1;
......@@ -868,19 +892,28 @@ static inline void gp_prune(SCM s, int tailp)
if(fr > gp->gp_fr) return;
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr) + 1;
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr);
int failci_p = 0;
if(!scm_is_eq(*ci,GP_GET_VAL(fr)))
failci_p = 1;
ci += + 1;
si = gp->gp_stack + GP_GET_VAR(fr);
cs = gp->gp_cons_stack + GP_GET_CONS(fr);
int vp = 0;
if(ci == gp->gp_ci && tailp)
if(ci == gp->gp_ci && tailp && !failci_p)
{
ci--;
vp = 1;
}
else
{
falsify_entires(ci,gp);
if(!failci_p)
falsify_entries(ci,gp);
ci = gp->gp_ci;
}
......@@ -927,7 +960,7 @@ static inline void gp_unwind_ncons(SCM fr, int ncons)
static inline void gp_unwind_tail(SCM fr)
{
gp_unwind_(fr,2,2,1);
gp_unwind_(fr,2,2,1);
//gp_unwind_(fr,0,0,0);
}
......@@ -1170,7 +1203,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *fr, struct gp_stack *gp)
scm_misc_error("gp-unwind/get_branch",
"reched eol prematurely ~a",
scm_list_1(scm_from_int(i)));
return SCM_EOL;
return fr;
}
}
}
......@@ -1204,7 +1237,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *fr, struct gp_stack *gp)
scm_misc_error("gp-unwind/get_branch",
"reched eol prematurely ~a",
scm_list_1(scm_from_int(i)));
return SCM_EOL;
return fr;
}
}
fr -= GP_FRAMESIZE;
......@@ -1560,6 +1593,10 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
cs = gp->gp_cons_stack + GP_GET_CONS (fr);
ci = gp->gp_cstack + GP_GET_VAL_VAL (fr);
if(!scm_is_eq(*ci,GP_GET_VAL(fr)))
scm_misc_error("restore-satate","ci self entry is not the same~%~a"
, scm_list_1(*ci));
if(si > gp->gp_si) si = gp->gp_si;
if(cs > gp->gp_cs) cs = gp->gp_cs;
......@@ -1678,3 +1715,4 @@ SCM_DEFINE(gp_add_unwind_hook, "gp-add-unwind-hook", 1, 0, 0, (SCM x),
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
//#define DB(X)
......@@ -2729,6 +2729,17 @@ SCM_DEFINE(gp_atomicp,"gp-atomic?",2,0,0,(SCM x, SCM s),
static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp);
void gp_unwind_dynstack(struct gp_stack *gp, scm_t_bits dyn_n);
SCM current_stack = SCM_BOOL_F;
SCM_DEFINE(gp_set_current_stack_x, "gp-set-current-stack", 1, 0, 0, (SCM x),
"resets the unifyier stacks")
#define FUNC_NAME gp_set_current_stack_x
{
current_stack = x;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
"resets the unifyier stacks")
#define FUNC_NAME s_gp_clear
......@@ -2746,6 +2757,13 @@ SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
gp->handlers = SCM_EOL;
gp->_logical_ = 0;
gp_debug0("clear end\n");
scm_fluid_set_x(current_stack,
scm_cons(scm_cons(GP_GET_SELF(gp->gp_fr),
GP_GET_VAL (gp->gp_fr)),
SCM_EOL));
return SCM_BOOL_T;
}
#undef FUNC_NAME
......
......@@ -313,7 +313,9 @@
(fluid-set! *gp* (gp-make-stack 0 0 5000000 5000000 5000000 1000000))
(define *current-stack* (make-fluid '()))
(fluid-set! *current-stack* (newf (fluid-ref *current-stack*)))
((@@(logic guile-log code-load) gp-set-current-stack) *current-stack*)
(gp-clear 1)
;(fluid-set! *current-stack*
(define (gp-var-set! v val)
......
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