engines now works as it should

parent d9a2ab53
...@@ -142,6 +142,10 @@ ...@@ -142,6 +142,10 @@
gp-make-struct gp-make-struct
gp-set-struct gp-set-struct
gp-store-engine-guards
gp-restore-engine-guards
gp-new-engine
gp-set-engine
gp-pop-engine gp-pop-engine
gp-push-engine gp-push-engine
gp-peek-engine gp-peek-engine
......
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
#:use-module (logic guile-log guile-prolog dynamic-features) #:use-module (logic guile-log guile-prolog dynamic-features)
#:use-module (logic guile-log dynamic-features) #:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log umatch) #:use-module (logic guile-log umatch)
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log iso-prolog) #:use-module (logic guile-log iso-prolog)
#:export (engine_create #:export (engine_create
engine_next engine_next
...@@ -27,74 +28,121 @@ ...@@ -27,74 +28,121 @@
(<define> (engine_fetch term) (<define> (engine_fetch term)
(copy_term (variable-ref (car (<postbox-ref>))) 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))) (let ((engine (gp-make-engine size)))
(letrec ((state #f) (letrec ((state #f)
(guards #f)
(path #f)
(postbox (make-variable #f)) (postbox (make-variable #f))
(on-result (on-result
(lambda () (lambda ()
(match state (match state
(#:exit (#:exit
(set! engine #f)) (set! engine #f)
state)
((#:throw e) ((#:throw e)
(set! engine #f)) (set! engine #f)
(_ #t)))) state)
(_
state))))
(start-f (start-f
(lambda (s) (lambda (s)
(set! start-f next) (if engine
(let ((s2 (gp-push-engine s engine))) (begin
(set! state (set! start-f next)
(stub-scm (let ((s2 #f)
(lambda () (list #:exit)) (pth #f)
(lambda (s p . x) (g (gp-store-engine-guards)))
(cons* #:finish s p x)) (dynamic-wind
goal (lambda ()
postbox (set! g (gp-store-engine-guards))
(lambda () ret))) (if path
(on-result) (set! pth
(gp-pop-engine) (gp-set-engine path))
state))) (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
s2
(lambda ()
(set! engine #f)
#:exit)
(lambda (s p x)
(list #:finish s p))
goal
postbox
(lambda () ret)))
(on-result))
(lambda ()
(set! guards (gp-store-engine-guards))
(set! path (gp-set-engine pth))
(gp-restore-engine-guards g)))))
#:exit)))
(next (next
(lambda (s) (lambda (s)
(match state (let ((pth #f)
(#:exit (g #f))
state) (dynamic-wind
((#:throw e) (lambda ()
state) (set! g (gp-store-engine-guards))
(set! pth (gp-set-engine path))
((#:yield s p cc x) (gp-restore-engine-guards guards))
(let ((s (gp-push-engine s engine)))
(set! state (cc s p)) (lambda ()
(gp-pop-engine) (if engine
(cons x state))) (match state
(#:exit
((#:finish s p) state)
(let ((s (gp-push-engine s engine)))
(set! state (p)) ((#:throw e)
(gp-pop-engine) state)
(cons template state))))))
((#:yield s0 p0 cc x)
(set! state (cc s0 p0))
state)
((#:finish _ p x)
(set! state (p))
state))
#:exit))
(lambda ()
(set! guards (gp-store-engine-guards))
(set! path (gp-set-engine pth))
(gp-restore-engine-guards g))))))
(ret (ret
(lambda (kind s . term) (lambda (kind s . term)
(match kind (match kind
(#:run (start-f s)) (#:run (start-f s))
(#:post (apply variable-set! postbox term)) (#:post (apply variable-set! postbox term))
(#:exist (#:finish
(match state (set! engine #f))
(((#:throw) . _) #f) (#:exist
(#:exit #f) (and engine
(_ #f))))))) (match state
((#:throw . _) #f)
(#:exit #f)
(_ #t))))))))
(set-procedure-property! ret 'engine #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))) ret)))
(<define> (is_engine term) (<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) (<define> (engine_next engine term)
(let* ((engine (<lookup> engine)) (let* ((engine (<lookup> engine))
(res (engine #:run S term))) (res (engine #:run S)))
(<<match>> (#:mode -) (res) (<<match>> (#:mode -) (res)
(#:exit (#:exit
<fail>) <fail>)
...@@ -104,15 +152,15 @@ ...@@ -104,15 +152,15 @@
(copy_term e ee) (copy_term e ee)
(throw ee))) (throw ee)))
((template #:finish s p) ((#:finish s p x)
(copy_term template term)) (<=> x term))
((template #:yield s p cc) ((#:yield s p cc x)
(copy_term template term))))) (<=> x term)))))
(<define> (engine_next_reified engine term) (<define> (engine_next_reified engine term)
(let* ((engine (<lookup> engine)) (let* ((engine (<lookup> engine))
(res (engine #:run S term))) (res (engine #:run S)))
(<<match>> (#:mode -) (res) (<<match>> (#:mode -) (res)
(#:exit (#:exit
(<=> "no" term)) (<=> "no" term))
...@@ -121,11 +169,11 @@ ...@@ -121,11 +169,11 @@
(copy_term (vector (list "exception" e)) (copy_term (vector (list "exception" e))
term)) term))
((template #:finish s p (x)) ((#:finish s p x)
(copy_term (vector (list "the" template)) term)) (<=> ,(vector (list "the" x)) term))
((template #:yield s p cc (x)) ((#:yield s p cc x)
(copy_term (vector (list "the" template)) term))))) (<=> ,(vector (list "the" x)) term)))))
(define engine_post (define engine_post
(<case-lambda> (<case-lambda>
...@@ -138,7 +186,7 @@ ...@@ -138,7 +186,7 @@
(engine_post engine term) (engine_post engine term)
(engine_next engine reply)))) (engine_next engine reply))))
(<define> (engine_self engine) (<=> engine (cdr (<postbox-ref>)))) (<define> (engine_self engine) (<=> engine ,((cdr (<postbox-ref>)))))
(<define> (current_engine engine) (<define> (current_engine engine)
(is_engine engine) (is_engine engine)
...@@ -152,19 +200,28 @@ ...@@ -152,19 +200,28 @@
x))) x)))
(<define> (create-engine-scm t g name size engine) (<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) (<lambda> (a b)
(stub g a b))))) (stub t g a b)))))
(<=> engine e))) (<=> engine e)))
(<define> (ret_e e) (<ret> (list #:throw e)))
(<define> (ret_g t) (<ret> (list #:finish S P t)))
(compile-prolog-string " (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) :- f(Term,Goal,A,B) :-
with_fluid_guard_dynamic_object(scm[postbox],g(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,[]) :- !.
parse_ops([],Ops,Defaults) :- !, parse_ops([],Ops,Defaults) :- !,
......
...@@ -53,7 +53,7 @@ ...@@ -53,7 +53,7 @@
(let ((fnm (procedure-property f 'name))) (let ((fnm (procedure-property f 'name)))
(if fnm (if fnm
fnm fnm
(pk 'old (old-pn f))))) (old-pn f))))
(define (<wrap> f . l) (define (<wrap> f . l)
......
...@@ -1603,7 +1603,12 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e), ...@@ -1603,7 +1603,12 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
{ {
cdr = scm_cons(SCM_EOL,SCM_EOL); 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)); ss = scm_cons(carss , scm_cons(SCM_CAR(cdr), gp_engine_path));
SCM_SETCAR(x, s); SCM_SETCAR(x, s);
...@@ -1612,6 +1617,53 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e), ...@@ -1612,6 +1617,53 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
} }
#undef FUNC_NAME #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), SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 1, 0, 0, (SCM l),
"") "")
#define FUNC_NAME s_gp_combine_engine #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), ...@@ -1971,6 +1971,29 @@ SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 2, 0, 0, (SCM cont, SCM K),
//#define DB(X) //#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), 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") "if s points to a numbered frame, then we will clear it")
......
...@@ -1325,11 +1325,11 @@ static inline SCM gp_newframe_choice(SCM s) ...@@ -1325,11 +1325,11 @@ static inline SCM gp_newframe_choice(SCM s)
else else
{ {
s = SCM_PACK(0); s = SCM_PACK(0);
l = SCM_EOL; l = scm_cons(SCM_EOL,gp_engine_path);
} }
if(scm_is_eq(l, SCM_UNBOUND)) if(scm_is_eq(l, SCM_UNBOUND))
l = SCM_EOL; l = scm_cons(SCM_EOL,gp_engine_path);
{ {
SCM ret; SCM ret;
......
...@@ -161,6 +161,10 @@ SCM_API SCM gp_code_to_int(SCM x); ...@@ -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_make_null_procedure(SCM n, SCM def);
SCM_API SCM gp_fill_null_procedure(SCM proc, SCM addr, SCM l); 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_push_engine(SCM s, SCM engine);
SCM_API SCM gp_pop_engine(); SCM_API SCM gp_pop_engine();
SCM_API SCM gp_peek_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