engines now works as it should

parent d9a2ab53
......@@ -142,6 +142,10 @@
gp-make-struct
gp-set-struct
gp-store-engine-guards
gp-restore-engine-guards
gp-new-engine
gp-set-engine
gp-pop-engine
gp-push-engine
gp-peek-engine
......
......@@ -4,6 +4,7 @@
#:use-module (logic guile-log guile-prolog dynamic-features)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log iso-prolog)
#:export (engine_create
engine_next
......@@ -27,74 +28,121 @@
(<define> (engine_fetch term)
(copy_term (variable-ref (car (<postbox-ref>))) term))
(define (generate-engine s size name template goal)
(define (generate-engine s size name goal)
(let ((engine (gp-make-engine size)))
(letrec ((state #f)
(guards #f)
(path #f)
(postbox (make-variable #f))
(on-result
(lambda ()
(match state
(#:exit
(set! engine #f))
(set! engine #f)
state)
((#:throw e)
(set! engine #f))
(_ #t))))
(set! engine #f)
state)
(_
state))))
(start-f
(lambda (s)
(if engine
(begin
(set! start-f next)
(let ((s2 (gp-push-engine s engine)))
(let ((s2 #f)
(pth #f)
(g (gp-store-engine-guards)))
(dynamic-wind
(lambda ()
(set! g (gp-store-engine-guards))
(if path
(set! pth
(gp-set-engine path))
(let ((s2.p (gp-new-engine engine)))
(set! s2 (car s2.p))
(set! pth (cdr s2.p))))
(if guards
(gp-restore-engine-guards guards)))
(lambda ()
(set! state
(stub-scm
(lambda () (list #:exit))
(lambda (s p . x)
(cons* #:finish s p x))
s2
(lambda ()
(set! engine #f)
#:exit)
(lambda (s p x)
(list #:finish s p))
goal
postbox
(lambda () ret)))
(on-result)
(gp-pop-engine)
state)))
(on-result))
(lambda ()
(set! guards (gp-store-engine-guards))
(set! path (gp-set-engine pth))
(gp-restore-engine-guards g)))))
#:exit)))
(next
(lambda (s)
(let ((pth #f)
(g #f))
(dynamic-wind
(lambda ()
(set! g (gp-store-engine-guards))
(set! pth (gp-set-engine path))
(gp-restore-engine-guards guards))
(lambda ()
(if engine
(match state
(#:exit
state)
((#:throw e)
state)
((#:yield s p cc x)
(let ((s (gp-push-engine s engine)))
(set! state (cc s p))
(gp-pop-engine)
(cons x state)))
((#:yield s0 p0 cc x)
(set! state (cc s0 p0))
state)
((#:finish s p)
(let ((s (gp-push-engine s engine)))
((#:finish _ p x)
(set! state (p))
(gp-pop-engine)
(cons template state))))))
state))
#:exit))
(lambda ()
(set! guards (gp-store-engine-guards))
(set! path (gp-set-engine pth))
(gp-restore-engine-guards g))))))
(ret
(lambda (kind s . term)
(match kind
(#:run (start-f s))
(#:post (apply variable-set! postbox term))
(#:finish
(set! engine #f))
(#:exist
(and engine
(match state
(((#:throw) . _) #f)
((#:throw . _) #f)
(#:exit #f)
(_ #f)))))))
(_ #t))))))))
(set-procedure-property! ret 'engine #t)
(set-procedure-property! ret 'name (name-it name))
(set-procedure-property!
ret 'name (string->symbol (format #f "e<~a>" (name-it name))))
ret)))
(<define> (is_engine term)
(when (procedure-property (<lookup> term) 'engine)))
(when (and (procedure? (<lookup> term))
(procedure-property (<lookup> term) 'engine))))
(<define> (engine_next engine term)
(let* ((engine (<lookup> engine))
(res (engine #:run S term)))
(res (engine #:run S)))
(<<match>> (#:mode -) (res)
(#:exit
<fail>)
......@@ -104,15 +152,15 @@
(copy_term e ee)
(throw ee)))
((template #:finish s p)
(copy_term template term))
((#:finish s p x)
(<=> x term))
((template #:yield s p cc)
(copy_term template term)))))
((#:yield s p cc x)
(<=> x term)))))
(<define> (engine_next_reified engine term)
(let* ((engine (<lookup> engine))
(res (engine #:run S term)))
(res (engine #:run S)))
(<<match>> (#:mode -) (res)
(#:exit
(<=> "no" term))
......@@ -121,11 +169,11 @@
(copy_term (vector (list "exception" e))
term))
((template #:finish s p (x))
(copy_term (vector (list "the" template)) term))
((#:finish s p x)
(<=> ,(vector (list "the" x)) term))
((template #:yield s p cc (x))
(copy_term (vector (list "the" template)) term)))))
((#:yield s p cc x)
(<=> ,(vector (list "the" x)) term)))))
(define engine_post
(<case-lambda>
......@@ -138,7 +186,7 @@
(engine_post engine term)
(engine_next engine reply))))
(<define> (engine_self engine) (<=> engine (cdr (<postbox-ref>))))
(<define> (engine_self engine) (<=> engine ,((cdr (<postbox-ref>)))))
(<define> (current_engine engine)
(is_engine engine)
......@@ -152,19 +200,28 @@
x)))
(<define> (create-engine-scm t g name size engine)
(let ((e (generate-engine S (<lookup> size) (<lookup> name) t
(let ((e (generate-engine S (<lookup> size) (<lookup> name)
(<lambda> (a b)
(stub g a b)))))
(stub t g a b)))))
(<=> engine e)))
(<define> (ret_e e) (<ret> (list #:throw e)))
(<define> (ret_g t) (<ret> (list #:finish S P t)))
(compile-prolog-string "
g(Goal,A,B) :- do[(fluid-set! postbox (cons A B))], Goal.
g(Term,Goal,A,B) :-
do[(fluid-set! postbox (cons A B))],
Goal,
copy_term(Term,T),
ret_g(T).
f(Goal,A,B) :-
with_fluid_guard_dynamic_object(scm[postbox],g(Goal,A,B)).
f(Term,Goal,A,B) :-
with_fluid_guard_dynamic_object(scm[postbox],g(Term,Goal,A,B)).
stub(Goal,A,B) :- catch(f(Goal,box,engine),E,ret(E)).
stub(Term,Goal,A,B) :-
catch(f(Term,Goal,A,B),E,ret_e(E)).
parse_ops([],Ops,[]) :- !.
parse_ops([],Ops,Defaults) :- !,
......
......@@ -53,7 +53,7 @@
(let ((fnm (procedure-property f 'name)))
(if fnm
fnm
(pk 'old (old-pn f)))))
(old-pn f))))
(define (<wrap> f . l)
......
......@@ -1604,6 +1604,11 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
cdr = scm_cons(SCM_EOL,SCM_EOL);
}
if(!SCM_CONSP(cdr))
{
cdr = scm_cons(SCM_EOL,SCM_EOL);
}
ss = scm_cons(carss , scm_cons(SCM_CAR(cdr), gp_engine_path));
SCM_SETCAR(x, s);
......@@ -1612,6 +1617,53 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
}
#undef FUNC_NAME
SCM_DEFINE(gp_new_engine, "gp-new-engine", 1, 0, 0, (SCM e),
"")
#define FUNC_NAME s_gp_new_engine
{
SCM x = scm_cons(SCM_EOL,e);
SCM path = gp_engine_path;
gp_debug0("Push Engine>\n");
gp_engine_path = scm_cons(x , SCM_EOL);
scm_fluid_set_x(gp_current_stack,e);
{
struct gp_stack *gp = get_gp();
gp_clear(SCM_BOOL_F);
SCM ss = scm_fluid_ref(current_stack); //Sooo confusing TODO: FIXME
SCM carss = gp_car(ss,ss);
SCM cdr = scm_cons(SCM_EOL,SCM_EOL);
ss = scm_cons(carss , scm_cons(SCM_EOL, gp_engine_path));
return scm_cons(ss, path);
}
}
#undef FUNC_NAME
SCM_DEFINE(gp_set_engine, "gp-set-engine", 1, 0, 0, (SCM path),
"")
#define FUNC_NAME s_gp_set_engine
{
SCM e = SCM_CDR(SCM_CAR(path));
SCM pathout = gp_engine_path;
gp_engine_path = path;
scm_fluid_set_x(gp_current_stack,e);
return pathout;
}
#undef FUNC_NAME
SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 1, 0, 0, (SCM l),
"")
#define FUNC_NAME s_gp_combine_engine
......
......@@ -1971,6 +1971,29 @@ SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 2, 0, 0, (SCM cont, SCM K),
//#define DB(X)
SCM make_rguards(SCM);
SCM_DEFINE(gp_store_engine_guards, "gp-store-engine-guards", 0, 0, 0, (),
"store a engine continuation guards")
#define FUNC_NAME s_gp_store_engine_guards
{
struct gp_stack *gp = get_gp();
SCM ret = make_rguards(gp->rguards);
return ret;
}
#undef FUNC_NAME
SCM_DEFINE(gp_restore_engine_guards, "gp-restore-engine-guards", 1, 0, 0,
(SCM guard_data),
"restore a engine continuation point")
#define FUNC_NAME s_gp_restore_engine_guards
{
eval_rguards(guard_data, 0);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_clear_frame_x, "gp-clear-frame!", 1, 0, 0, (SCM s),
"if s points to a numbered frame, then we will clear it")
......
......@@ -1325,11 +1325,11 @@ static inline SCM gp_newframe_choice(SCM s)
else
{
s = SCM_PACK(0);
l = SCM_EOL;
l = scm_cons(SCM_EOL,gp_engine_path);
}
if(scm_is_eq(l, SCM_UNBOUND))
l = SCM_EOL;
l = scm_cons(SCM_EOL,gp_engine_path);
{
SCM ret;
......
......@@ -161,6 +161,10 @@ SCM_API SCM gp_code_to_int(SCM x);
SCM_API SCM gp_make_null_procedure(SCM n, SCM def);
SCM_API SCM gp_fill_null_procedure(SCM proc, SCM addr, SCM l);
SCM_API SCM gp_new_engine(SCM e);
SCM_API SCM gp_set_engine(SCM path);
SCM_API SCM gp_restore_engine_guards(SCM cont);
SCM_API SCM gp_store_engine_guards();
SCM_API SCM gp_push_engine(SCM s, SCM engine);
SCM_API SCM gp_pop_engine();
SCM_API SCM gp_peek_engine();
......
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