engine.scm compiles

parent acf6a108
(define-module (logic guile-log guile-prolog engine)
#:use-module (ice-9 match)
#:use-module (logic guile-log)
#:use-module ((logic code-load) #:select
())
#: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 iso-prolog)
#:export (engine_create
engine_next
......@@ -12,21 +13,22 @@
engine_fetch
is_engine
engine_self
current_engine)
current_engine))
(<define> (engine_yield term) (<ret> (list #yield S P CC term)))
(<define> (engine_yield term) (<ret> (list #:yield S P CC term)))
(<define> (stub-scm goal box engine)
(<with-postbox> (cons box engine)
(goal)))
(goal box engine))
(define postbox (make-fluid #f))
(<wrap> add-fluid-dynamics postbox)
(define (<postbox-ref>) (fluid-ref postbox))
(<define> (engine_fetch term)
(copy_term (variable-ref (car (<postbox-ref>))) term))
(define postbox (make-variable #f))
(define (generate-engine s size name template goal)
(let ((engine (make-engine size)))
(let ((engine (gp-make-engine size)))
(letrec ((state #f)
(postbox (make-variable #f))
(on-result
......@@ -41,7 +43,7 @@
(start-f
(lambda (s)
(set! start-f next)
(let ((s2 (gp-new-engine s engine)))
(let ((s2 (gp-push-engine s engine)))
(set! state
(stub-scm
(lambda () (list #:exit))
......@@ -55,7 +57,7 @@
state)))
(next
(lambda (s term)
(lambda (s)
(match state
(#:exit
state)
......@@ -63,32 +65,32 @@
state)
((#:yield s p cc x)
(let ((s (gp-old-engine s engine)))
(let ((s (gp-push-engine s engine)))
(set! state (cc s p))
(gp-pop-engine)
(cons x state)))
((#:finish s p)
(let ((s (gp-old-engine s engine)))
(let ((s (gp-push-engine s engine)))
(set! state (p))
(gp-pop-engine)
(cons template state))))))
(ret
(lambda (kind s term)
(lambda (kind s . term)
(match kind
(#:run (start-f s term))
(#:post (variable-set! postbox term))
(#:run (start-f s))
(#:post (apply variable-set! postbox term))
(#:exist
(match state
(((#:throw) . _) #f)
(#exit #f)
(#:exit #f)
(_ #f)))))))
(procedure-property-set! ret 'engine #t)
(procedure-property-set! ret 'name (name-it name))
(set-procedure-property! ret 'engine #t)
(set-procedure-property! ret 'name (name-it name))
ret)))
(<define> (is_engine term)
(if (procedure-property (<lookup> term))))
(when (procedure-property (<lookup> term) 'engine)))
(<define> (engine_next engine term)
(let* ((engine (<lookup> engine))
......@@ -113,7 +115,7 @@
(res (engine #:run S term)))
(<<match>> (#:mode -) (res)
(#:exit
(<=> "no" trem))
(<=> "no" term))
((#:throw e)
(copy_term (vector (list "exception" e))
......@@ -126,7 +128,7 @@
(copy_term (vector (list "the" template)) term)))))
(define engine_post
(case-lambda
(<case-lambda>
((engine term)
(let ((engine (<lookup> engine)))
(<var> (t)
......@@ -140,7 +142,7 @@
(<define> (current_engine engine)
(is_engine engine)
(if ((<lookup> engine) #:exist #f #f)))
(when ((<lookup> engine) #:exist #f #f)))
(define (name-it x)
(if (procedure? x)
......@@ -151,25 +153,30 @@
(<define> (create-engine-scm t g name size engine)
(let ((e (generate-engine S (<lookup> size) (<lookup> name) t
(<lambda> ()
(stub g)))))
(<lambda> (a b)
(stub g a b)))))
(<=> engine e)))
(compile-prolog-string "
g(Goal,A,B) :- do[(fluid-set! postbox (cons A B))], Goal.
f(Goal,A,B) :-
with_fluid_guard_dynamic_object(scm[postbox],g(Goal,A,B)).
stub(Goal) :- catch(Goal,E,set_e(E)).
stub(Goal,A,B) :- catch(f(Goal,box,engine),E,ret(E)).
parse_ops([],Ops,[]) :- !.
parse_ops([],Ops,Defaults) :- !.
parse_ops([],Ops,Defaults) :- !,
parse_ops(Defaults,Ops,[]).
parse_ops([X|L],Ops,Defaults) :-
(member(X,Ops) -> true ; true),
parse_ops(L,Ops,Defaults).
defaults([alias(noname),global(100),local(100),trail(100)]).
defaults([\"alias\"(noname),\"global\"(100),\"local\"(100),\"trail\"(100)]).
engine_create(Template, Goal, Engine, Ops) :-
default(Default),
parse_ops(Ops, [alias(Name),local(Size)], Defaults),
defaults(Defaults),
parse_ops(Ops, [\"alias\"(Name),\"local\"(Size)], Defaults),
copy_term([Template,Goal],[T,G]),
'create-engine-scm'(T,G,Name,Size,Engine).
")
......
......@@ -4,6 +4,7 @@
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log guile-prolog engine)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog set)
#:use-module (logic guile-log guile-prolog attribute)
......
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