persistance starts to work

parent ab08bea9
......@@ -68,6 +68,7 @@ PSSOURCES = \
logic/guile-log/prolog/namespace.scm \
logic/guile-log/guile-prolog/closure.scm \
logic/guile-log/memoize.scm \
logic/guile-log/prolog/persist.scm \
logic/guile-log/prolog/parser.scm \
logic/guile-log/prolog/run.scm \
logic/guile-log/prolog/goal.scm \
......
......@@ -343,18 +343,20 @@ a natural generational mapping to help in constructing a match tree.
1))))
((theory setbits)
(let ((deps (get-i->subs theory))
(sups (get-i->sups theory)))
(define (find-all-leafs)
(let lp ((ss (bits-to-is setbits)) (leafs 0))
(if (pair? ss)
(let ((i (car ss)))
(aif (ih) (get-i deps i)
(if (= i (logand setbits ih))
(lp (cdr ss) (logior leafs i))
(lp (cdr ss) leafs))
(error "compile-set-representatoin has nonmatched bit")))
leafs)))
(if (= setbits 0)
#f
(let ((deps (get-i->subs theory))
(sups (get-i->sups theory)))
(define (find-all-leafs)
(let lp ((ss (bits-to-is setbits)) (leafs 0))
(if (pair? ss)
(let ((i (car ss)))
(aif (ih) (get-i deps i)
(if (= i (logand setbits ih))
(lp (cdr ss) (logior leafs i))
(lp (cdr ss) leafs))
(error "compile-set-representatoin has nonmatched bit")))
leafs)))
(define (find-all-newcombers downbits new-downbits)
(let lp1 ((ss (bits-to-is new-downbits)) (news 0))
......@@ -432,7 +434,7 @@ a natural generational mapping to help in constructing a match tree.
#:subs j->subs
#:sups j->sups)))))
new-theory))))
new-theory)))))
#|
Balanced binary tree compilation
......
(define-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog persist)
#:use-module (logic guile-log scmspace)
#:use-module (logic guile-log prolog symbols)
#:use-module (logic guile-log hash-dynamic)
......@@ -44,6 +45,12 @@
;; profile
lambda define
use-modules
new_persister
persist_ref
persist_set
load_persists
save_persists
accessify_predicate
;;swi stuff
meta_predicate public
......
......@@ -713,6 +713,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...)))))
(set-procedure-property! name 'module get-module)
(set-procedure-property! name 'shallow #t)
name)))))
(define-syntax <define*>
......@@ -724,6 +725,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...)))))
(set-procedure-property! name 'module get-module)
(set-procedure-property! name 'shallow #t)
name)))))
......
......@@ -116,16 +116,16 @@
(aif (f) (module-ref mod name)
(log 'reg-obj i f)
(error
(format
#f
"symbol ~a not present in module ~a at unserializing" name path)))
(format
#f
"module ~a is not present at unserializing" path)))))
(format
#f
"symbol ~a not present in module ~a at unserializing" name path)))
(format
#f
"module ~a is not present at unserializing" path)))))
(((? (M gp-pair))) 1)
(((? (M code)) i a)
(((? (M gp-pair))) 1)
(((? (M code)) i a)
(log 'reg-obj i (int-to-code a)))
(((? (M atom)) i a)
(log 'reg-obj i a)
......@@ -172,9 +172,9 @@
(gp-fill-null-procedure
proc (find-fkn-adress path addr) l)))
(((? (M set-accessor)) obj data)
(let* ((obj (log 'rev-lookup obj))
(data (log 'rev-lookup data))
(((? (M set-accessor)) obj data)
(let* ((obj (log 'rev-lookup obj))
(data (log 'rev-lookup data))
(set (object-property obj 'accessor-setter)))
(if set
(set obj data)
......@@ -370,7 +370,7 @@
((named)
(let ()
(define (mk procedure-property)
(let ((path (procedure-property x 'path)))
(let ((path (procedure-property x 'module)))
(if path
(let ((name (if (procedure? x)
(procedure-name x)
......@@ -433,7 +433,7 @@
(if i
i
(log make-var x l ...))))
(define-syntax-rule (do-if-deep x i code)
(let ()
(define (f n) (not (n x 'shallow)))
......@@ -485,10 +485,10 @@
(define (make-an-access x y)
(let ((i (mk-name 'make-accessor x)))
(do-if-deep x i
(let* ((data (persist log (y x)))
(obj (persist log x #f)))
(log 'set-accessor obj data)))))
(let* ((data (persist log (y)))
(obj (persist log x #f)))
(log 'set-accessor obj data)
i)))
(define (make-a-vector)
(let* ((n (vector-length x))
......@@ -563,5 +563,5 @@
(set! i (+ i 1)))))
;(set-procedure-property! test 'shallow #t)
(set-procedure-property! test 'name 'test)
(set-procedure-property! test 'path '(logic guile-log persistance))
(set-procedure-property! test 'name 'test)
(set-procedure-property! test 'module '(logic guile-log persistance))
......@@ -163,6 +163,7 @@
(define! Fkn xxf))
(set-procedure-property! xxf 'module (module-name (current-module)))
(set-procedure-property! xxf 'shallow #t)
(set-procedure-property! xxf 'name Fkn)))
(define (define-or-set-fkn! f x)
......@@ -179,6 +180,7 @@
(define! f xxf))
(set-procedure-property! xxf 'module (module-name (current-module)))
(set-procedure-property! xxf 'shallow #t)
(set-procedure-property! xxf 'name f)))
......@@ -648,7 +650,8 @@
#`(begin
(syntax-parameterize ((Fkn (lambda (x) #''nm)))
(define-or-set! #,lam))
(set-procedure-property! nm 'module dir))))
(set-procedure-property! nm 'module dir)
(set-procedure-property! nm 'shallow #t))))
(define-syntax apply-fu
(syntax-rules (unquote)
......@@ -1008,6 +1011,7 @@
;(format #t "Defined non defined variable ~a~%" x)
(module-define! mod x f)
(set-procedure-property! f 'module (module-name mod))
(set-procedure-property! f 'shallow #t)
(set-procedure-property! f 'name x))))
(lp l))
(() #t)))))
......
......@@ -17,7 +17,8 @@
#:export (asserta assertz assertaf assertzf
clause retract abolish current_predicate
asserta-source assertz-source
asserta-source+ assertz-source+))
asserta-source+ assertz-source+
accessify_predicate))
(define once-f #f)
(define (maybe-call x)
(if (@@ (logic guile-log prolog base) *eval-only*)
......@@ -536,3 +537,16 @@
(type_error predicate_indicator X))))
(set! (@@ (logic guile-log prolog parser) assertz-source+) assertz-source+)
(<define> (accessify_predicate f)
(<recur> lp ((ff (<lookup> f)))
(if (not (dynamic? ff))
(if (procedure? ff)
(if (object-property ff 'prolog-symbol)
(lp (ff))
(type_error predicate_indicator f))
(type_error predicate_indicator f))
(<let> ((env (object-property ff 'dynamic-data)))
(<code>
(set-object-property! f 'get-accessor (vector-ref env 4))
(set-object-property! f 'set-accessor (vector-ref env 5)))))))
(define-module (logic guile-log prolog persist)
#:use-module (logic guile-log)
#:use-module (logic guile-log persistance)
#:export (new_persister persist_ref persist_set
load_persists save_persists))
(<define*> (new_persister ret #:key (file "persist.scm"))
(<let> ((p (make-persister #:file file)))
(<code> (set-procedure-property! p 'name 'persister))
(<=> ret p)))
(<define> (persist_ref p i out)
(<let> ((i (<lookup> i)))
(if (procedure? i)
(<code> (set! i (procedure-name i)))
<cc>)
(<=> ,(persist-ref (<lookup> p) i) out)))
(<define> (persist_set p i in)
(<let> ((i (<lookup> i)))
(if (procedure? i)
(<code> (set! i (procedure-name i)))
<cc>)
(<code> (persist-set! (<lookup> p) (<lookup> i) in))))
(<define> (load_persists p)
(<code> (load-persists (<lookup> p))))
(<define> (save_persists p)
(<code> (save-persists (<lookup> p))))
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