swi prolog engine implementation

Makefile.am

@@ -100,6 +100,7 @@ PSSOURCES = \
 	logic/guile-log/iso-prolog.scm \
 	logic/guile-log/prolog/goal-expand.scm \
 	logic/guile-log/guile-prolog/set.scm \
+	logic/guile-log/guile-prolog/engine.scm \
 	logic/guile-log/guile-prolog/delay.scm \
 	logic/guile-log/guile-prolog/foldarg.scm \
 	logic/guile-log/guile-prolog/ops.scm \

logic/guile-log/guile-prolog/engine.scm

+(define-module (logic guile-log guile-prolog engine)
+  #:use-module (logic guile-log)
+  #:use-module ((logic code-load) #:select
+                ())
+                 
+  #:use-module (logic guile-log iso-prolog)
+  #:export (engine_create
+            engine_next
+            engine_next_reified
+            engine_post
+            engine_yield
+            engine_fetch
+            is_engine
+            engine_self
+            current_engine)
+
+(<define> (engine_yield term) (<ret> (list #yield S P CC term)))
+
+(<define> (stub-scm goal box engine)
+  (<with-postbox> (cons box engine)
+    (goal)))
+
+(<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)))
+    (letrec ((state      #f)
+             (postbox    (make-variable #f))
+             (on-result  
+              (lambda ()
+                (match state
+                  (#:exit 
+                   (set! engine #f))
+                  ((#:throw e)
+                   (set! engine #f))
+                  (_ #t))))
+                   
+             (start-f
+              (lambda (s)
+                (set! start-f next)
+                (let ((s2 (gp-new-engine s engine)))                  
+                  (set! state 
+                    (stub-scm
+                          (lambda () (list #:exit))
+                          (lambda (s p . x)
+                            (cons* #:finish s p x))
+                          goal
+                          postbox
+                          (lambda () ret)))
+                  (on-result)
+                  (gp-pop-engine)
+                  state)))
+                                       
+             (next
+              (lambda (s term)
+                (match state
+                  (#:exit
+                   state)
+                  ((#:throw e)
+                   state)
+
+                  ((#:yield s p cc x)
+                   (let ((s (gp-old-engine s engine)))
+                     (set! state (cc s p))
+                     (gp-pop-engine)
+                     (cons x state)))
+
+                  ((#:finish s p)
+                   (let ((s (gp-old-engine s engine)))
+                     (set! state (p))
+                     (gp-pop-engine)
+                     (cons template state))))))
+             (ret
+              (lambda (kind s term)
+                (match kind
+                  (#:run   (start-f s term))
+                  (#:post  (variable-set! postbox term))
+                  (#:exist 
+                  (match state
+                    (((#:throw) . _) #f)
+                    (#exit           #f)
+                    (_ #f)))))))
+      (procedure-property-set! ret 'engine #t)
+      (procedure-property-set! ret 'name (name-it name))
+      ret)))
+
+(<define> (is_engine term)
+  (if (procedure-property (<lookup> term))))
+
+(<define> (engine_next engine term)
+  (let* ((engine (<lookup> engine))
+         (res    (engine #:run S term)))
+    (<<match>> (#:mode -) (res)
+      (#:exit 
+       <fail>)
+
+      ((#:throw e)
+       (<var> (ee)
+         (copy_term e ee)
+         (throw ee)))
+
+      ((template #:finish s p)
+       (copy_term template term))
+
+      ((template #:yield s p cc)
+       (copy_term template term)))))
+
+(<define> (engine_next_reified engine term)
+  (let* ((engine (<lookup> engine))
+         (res    (engine #:run S term)))
+    (<<match>> (#:mode -) (res)
+      (#:exit 
+       (<=> "no" trem))
+
+      ((#:throw e)
+       (copy_term (vector (list "exception" e))
+                  term))
+
+      ((template #:finish s p (x))
+       (copy_term (vector (list "the" template)) term))
+
+      ((template #:yield s p cc (x))
+       (copy_term (vector (list "the" template)) term)))))
+
+(define engine_post 
+  (case-lambda
+    ((engine term)
+     (let ((engine (<lookup> engine)))
+       (<var> (t)
+          (copy_term term t)
+          (<code> (engine #:post S (<lookup> t))))))
+    ((engine term reply)
+     (engine_post engine term)
+     (engine_next engine reply))))
+
+(<define> (engine_self engine) (<=> engine (cdr (<postbox-ref>))))
+
+(<define> (current_engine engine)
+ (is_engine engine)
+ (if ((<lookup> engine) #:exist #f #f)))
+
+(define (name-it x)
+  (if (procedure? x)
+      (procedure-name x)
+      (if (string? x)
+          (string->symbol x)
+          x)))
+
+(<define> (create-engine-scm t g name size engine)
+  (let ((e (generate-engine S (<lookup> size) (<lookup> name) t
+                            (<lambda> ()
+                              (stub g)))))
+    (<=> engine e)))
+           
+(compile-prolog-string "
+
+ stub(Goal) :- catch(Goal,E,set_e(E)).
+  
+ parse_ops([],Ops,[]) :- !.
+ 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)]). 
+ engine_create(Template, Goal, Engine, Ops) :-
+   default(Default),
+   parse_ops(Ops, [alias(Name),local(Size)], Defaults),
+   copy_term([Template,Goal],[T,G]),
+   'create-engine-scm'(T,G,Name,Size,Engine).    
+")
+