persistance of prolog state now works

parent 4c78b2de
......@@ -18,6 +18,7 @@ PSSOURCES = \
ice-9/vset.scm \
logic/guile-log/scmspace.scm \
logic/guile-log/fstream.scm \
logic/guile-log/primitive.scm \
logic/guile-log/persistance.scm \
logic/guile-log/guile-log-pre.scm \
logic/guile-log/ck.scm \
......
......@@ -44,8 +44,10 @@
(define-named-object -rec?- (make-fluid #f))
(define-named-object -nonrec?- (make-fluid #f))
(<wrap> add-fluid-dynamics -mute?-)
(define *user-data* (make-fluid vlist-null))
(define-named-object *user-data* (make-fluid vlist-null))
(<wrap> add-vhash-dynamics *user-data*)
(<define> (user_set a v)
(<code> (fluid-set! *user-data* (vhash-cons (<lookup> a)
(<scm> v)
......@@ -210,7 +212,7 @@
(set! old #t))
((refp)
(persist-restate *persister*
(((@ (guile) read))))
((@ (guile) read)))
(set! old #t))
((rec) (begin
(fluid-set! -rec?- #t)
......
......@@ -5,6 +5,8 @@
#:use-module (logic guile-log code-load)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log primitive)
#:use-module (logic guile-log fstream)
#:export (make-persister
load-persists
save-persists
......@@ -67,6 +69,9 @@
(define atom 9)
(define code 10)
(define standard-vtable 11)
(define primitive 12)
(define vlist-null-i 13)
(define curstack 14)
(define set-gp-var 20)
(define set-var 21)
......@@ -78,6 +83,12 @@
(define set-gp-pair 28)
(define set-accessor 29)
(define (curstack? x)
(eq? x (fluid-ref ((@@ (logic guile-log code-load) gp-current-stack-ref)))))
(define (get-curstack)
(fluid-ref ((@@ (logic guile-log code-load) gp-current-stack-ref))))
(define (hash->assoc h)
(hash-fold
(lambda (k v l) (cons (cons k v) l))
......@@ -99,7 +110,15 @@
(let lp ((l (reverse (log 'data))))
(if (pair? l)
(begin
(match (pk (car l))
(match (car l)
(((? (M vlist-null-i)) i)
(let ((v vlist-null))
(log 'reg-obj i v)))
(((? (M curstack)) i)
(let ((v (get-curstack)))
(log 'reg-obj i v)))
(((? (M gp-var)) i)
(let ((v (gp-make-var)))
(log 'reg-obj i v)))
......@@ -151,6 +170,9 @@
(((? (M code)) i a)
(log 'reg-obj i (int-to-code a)))
(((? (M primitive)) i a)
(log 'reg-obj i (get-primitive a)))
(((? (M atom)) i a)
(log 'reg-obj i a)
a)
......@@ -444,10 +466,22 @@
(mk-atom i x
`(,code ,i ,(code-to-int x))))
((make-primitive)
(mk-atom i x
`(,primitive ,i ,(procedure-name x))))
((make-standard-vtable)
(mk-obj i x
`(,standard-vtable ,i)))
((make-vlist-null)
(mk-obj i x
`(,vlist-null-i ,i)))
((make-curstack)
(mk-obj i x
`(,curstack ,i)))
((make-gp-var)
(mk-obj i x
`(,gp-var ,i)))
......@@ -519,6 +553,14 @@
(j (persist log v)))
(log 'set-gp-var i id j)))))
(define (make-vlist-null)
(let ((i (mk-name 'make-vlist-null x)))
i))
(define (make-curstack)
(let ((i (mk-name 'make-curstack x)))
i))
(define (make-standard-vtable)
(let ((i (mk-name 'make-standard-vtable x)))
i))
......@@ -554,6 +596,10 @@
(vector->list x))))
(log 'set-vector i l)))))
(define (make-a-primitive)
(let ((i (mk-name 'make-primitive x)))
i))
(define (make-a-procedure)
(let* ((prim? (primitive? x))
(free (if prim? '() (program-free-variables x)))
......@@ -595,6 +641,13 @@
=>
(lambda (y)
(mk (lambda () (make-an-access x y)))))
((curstack? x)
(mk make-curstack))
((eq? x vlist-null)
(mk make-vlist-null))
((eq? x <standard-vtable>)
(mk make-standard-vtable))
((gp? x)
......@@ -610,7 +663,11 @@
((struct? x)
(mk make-a-struct))
((procedure? x)
(mk make-a-procedure))
(if (primitive? x)
(aif (it) (get-primitive x)
(mk make-a-primitive)
(error "non registred primitive"))
(mk make-a-procedure)))
((code-to-int x)
(mk make-a-code))
(else
......
(define-module (logic guile-log primitive)
#:use-module (system vm program)
#:use-module (logic guile-log code-load)
#:export (get-primitive))
(define m (make-hash-table))
(define f
(lambda (k v)
(if (and (variable? v) (variable-bound? v) (primitive? (variable-ref v)))
(hash-set! m k (variable-ref v)))))
(module-for-each f (resolve-module '(guile)))
(module-for-each f (resolve-module '(logic guile-log code-load)))
(define (get-primitive x)
(define nm (if (procedure? x) (procedure-name x) x))
(hash-ref m nm #f))
(define-module (logic guile-log prolog global)
#:use-module (logic guile-log)
#:use-module (logic guile-log persistance)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log prolog error)
......@@ -7,7 +8,7 @@
#:export (b_setval b_getval nb_setval nb_getval nb_current
setarg nb_setarg *globals-map*))
(define *globals-map* (make-fluid vlist-null))
(define-named-object *globals-map* (make-fluid vlist-null))
(<wrap> add-vhash-dynamics *globals-map*)
(<define> (b_setval atom val)
......
......@@ -1047,9 +1047,11 @@
(<define> (read* s term v vn si)
(<let*> ((s (<scm> s))
(fr (<newframe>))
(e (call-with-values
(lambda () (read-prolog-term S s (current-module)))
(lambda x x))))
(lambda x x))))
(<code> (<unwind> fr))
(<or>
(<and> (<=> ,(list term v vn si) e) <cut>)
(<=> ,(list term v vn si) ,(list end_of_file '() '() '())))
......
......@@ -39,4 +39,5 @@
(<state-set!> state)))
(define (persist-restate per key)
(<clear>)
(<state-set!> (persist-ref per key)))
......@@ -4,6 +4,7 @@
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log guile-prolog copy-term)
#:use-module (logic guile-log interleave)
#:use-module (logic guile-log persistance)
#:export (<stall> <continue> <take> <run> <eval> <ask>
<cont-ref> <cont-set!>
*gp-var-tr* *kanren-assq*
......@@ -35,7 +36,7 @@
(define bar build_attribut_representation)
(define *cc* (gp-make-var #f))
(define-named-object *cc* (gp-make-var #f))
(define (<stall> s p cc . l)
(gp-var-set *cc* (cons s (cons (cons p l) cc)) s)
......
......@@ -814,7 +814,7 @@ static inline SCM gp_store_state(struct gp_stack *gp)
//#define DB(X)
SCM_DEFINE(gp_gp_store_state, "gp-store-state", 1, 0, 0, (SCM s),
"sore a continuation point at the current state")
"store a continuation point at the current state")
#define FUNC_NAME s_gp_gp_store_state
{
SCM ret;
......@@ -858,6 +858,12 @@ static inline SCM * gp_get_branch(SCM *p, SCM *ci, struct gp_stack *gp)
return gp->gp_cstack;
}
if(scm_is_eq(SCM_CAR(pp), SCM_PACK(gp_save_tag)))
{
*p = pp;
return ci;
}
if(pp == *ci)
{
DB(printf("found it\n"));
......
......@@ -20,8 +20,10 @@
(define-module (logic guile-log umatch)
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log persistance)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log attributed)
#:use-module (logic guile-log persistance)
#:use-module (ice-9 match-phd-lookup)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 format)
......@@ -182,7 +184,7 @@
(lp (cdr l)))))
(fluid-set! inhibit-doit #f)))))
(define *var-attributator* (make-fluid '()))
(define-named-object *var-attributator* (make-fluid '()))
(define (gp-var! s)
(let ((v ((@@ (logic guile-log code-load) gp-var!) s)))
(if (not (fluid-ref inhibit-doit))
......@@ -257,7 +259,7 @@
(define *states* #t)
(define *gp* (gp-current-stack-ref))
(define-named-object *gp* (gp-current-stack-ref))
(fluid-set! *gp* (gp-make-stack 0 0 5000000 5000000 5000000))
(define *current-stack* (make-fluid '()))
......
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