engine.scm compiles

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