persistance

parent 0b3e99a2
This diff is collapsed.
......@@ -16,7 +16,9 @@
make-shallow
associate-getter-setter
name-object
name-object-deep
define-named-object
define-shallow-object
define-fluid-object
......@@ -37,9 +39,9 @@
(define gp-cons-set-2! (@@ (logic guile-log code-load) gp-cons-set-2!))
(define-method (pcopyable? x) #f)
(define-method (pdeep-copyable? x) #f)
(define-method (deep-pcopyable? x) #f)
(define-method (pcopy x) (error "could not copy"))
(define-method (pdeep-copyable? x) (error "could not deep copy"))
(define-method (deep-pcopy x) (error "could not deep copy"))
(define (default-print-func struct port)
(format port "<pre-struct>"))
......@@ -149,6 +151,26 @@
(p2 'load-repr (p1 'repr))
(p2 'get-tag 'x)))
(define (dump x f)
(let ((p (make-persister #:file f)))
(register-tag p 'x x)
(p 'save)))
(define (dumps x)
(let ((p (make-persister)))
(register-tag p 'x x)
(p 'save-str)))
(define (load file)
(let ((p (make-persister #:file file)))
(p 'load)
(p 'get-tag 'x)))
(define (loads s)
(let ((p (make-persister)))
(p 'load-str s)
(p 'get-tag 'x)))
(define (deep-copy x)
(let ((p1 (make-persister))
(p2 (make-persister)))
......@@ -186,10 +208,10 @@
(let ((v (cons 0 0)))
(log 'reg-obj i v)))
(((? (M make-object) i x) . _)
(((? (M make-object)) i x)
(log 'reg-obj i x))
(((? (M make-reducer) i x) . _)
(((? (M make-reducer)) i x)
(let* ((f (log 'rev-lookup x))
(o (f)))
(log 'reg-obj i o)))
......@@ -265,7 +287,8 @@
(v (log 'rev-lookup iv)))
(for-each
(lambda (x)
(apply (car x) o (cdr x))))))
(apply (car x) o (cdr x)))
v)))
(((? (M set-vector)) i l)
(let ((v (log 'rev-lookup i)))
......@@ -391,6 +414,9 @@
(hash->assoc globmap) iglob
(hash->assoc namemap) iname))
(define (f x)
(map (lambda (x) (cons (cdr x) (car x))) x))
(define (load-data data)
(set! tags (list-ref data 0))
(set! maps (assoc->hash (list-ref data 1)))
......@@ -429,8 +455,6 @@
((load)
(let* ((s (open-file file "r"))
(data (read s)))
(define (f x)
(map (lambda (x) (cons (cdr x) (car x))) x))
(close s)
(load-data data)
(unserialize self)
......@@ -549,9 +573,12 @@
(define (mk procedure-property)
(let ((path (procedure-property x 'module)))
(if path
(let ((name (if (procedure? x)
(procedure-name x)
(object-property x 'name))))
(let ((name (aif (it) (object-property x 'name)
it
(if (procedure? x)
(procedure-name x)
#f))))
(if name
(let* ((i (inc x))
(o (reg-global name path)))
......@@ -560,9 +587,12 @@
#f))
#f)))
(if (procedure? x)
(mk procedure-property)
(mk object-property))))
(aif (it) (mk object-property)
it
(if (procedure? x)
(mk procedure-property)
#f))))
((make-accessor)
#t)
......@@ -620,11 +650,11 @@
(log 'store-tag tag i)))
(define (register-tag-shallow log tag x)
(let ((i (persist log x #f #:shallow #t)))
(let ((i (persist log x #:shallow? #t)))
(log 'store-tag tag i)))
(define (register-tag-deep log tag x)
(let ((i (persist log x #f #:deep #t)))
(let ((i (persist log x #:deep? #t)))
(log 'store-tag tag i)))
(define log-log (make-fluid #f))
......@@ -634,9 +664,9 @@
(apply persist log l)
(error "Assumes a persist have been executed")))
(define* (persist log x #:optional (pred #t) #:key (shallow? #f) (deep? #f))
(define* (persist log x #:key (pred #t) (shallow? #f) (deep? #f))
(with-fluids ((log-log log))
(define* (persist log x #:optional (pred #t))
(define* (upersist log x #:optional (pred #t))
(define-syntax-rule (mk-name make-var x l ...)
(let ((i (log 'named x)))
(if i
......@@ -647,22 +677,22 @@
(let ((i (log 'named x)))
(if i
i
(log make-var (f)))))
(log make-var x (f)))))
(define (dpersist log x)
(define (dpersist log x . l)
(if shallow?
(list #:shallow x)
(persist log x pred)))
(list #:shallow x)
(apply upersist log x l)))
(define-syntax-rule (do-if-deep x i code)
(let ()
(define (f n) (not (n x 'shallow)))
(define (p)
(if (procedure? x)
(if (f procedure-property)
(f object-property)
#f)
(f object-property)))
(define (p)
(if (f object-property)
(if (procedure? x)
(f procedure-property)
#t)
#f))
(if (p) code)
i))
......@@ -751,14 +781,24 @@
(mk-name-f 'make-object x (lambda () (pcopy x))))
(define (make-deep-copy)
(match (deep-pcopy x deep?)
((#:obj x2)
(mk-name-f 'make-object x x2))
((#:reduce make data)
(let ((imake (mk-name-f 'make-reducer (lambda () (dpersist log make)))))
(do-if-deep x imake
(let ((id (dpersist log data)))
(log 'set-reducer imake id)))))))
(let ((i (log 'named x)))
(if i
(do-if-deep x i
(match (deep-pcopy x deep?)
((#:obj x2)
(mk-name-f 'make-object x (lambda () x2)))
((#:reduce make data)
(let ((id (dpersist log data)))
(log 'set-reducer i id)))))
(match (deep-pcopy x deep?)
((#:obj x2)
(mk-name-f 'make-object x (lambda () x2)))
((#:reduce make data)
(let ((i (mk-name-f 'make-reducer x
(lambda () (dpersist log make)))))
(let ((id (dpersist log data)))
(log 'set-reducer i id))))))))
(define (make-a-primitive)
......@@ -801,7 +841,6 @@
(if i
i
(code))))
(cond
((and pred (object-property x 'get-accessor))
=>
......@@ -861,8 +900,19 @@
(else
(mk make-atom))))
(persist log x pred)))
(upersist log x pred)))
(define-syntax-rule (name-object f)
(let ((y f))
(make-shallow y)
(set-object-property! y 'name 'f)
(set-object-property! y 'module (module-name (current-module)))))
(define-syntax-rule (name-object-deep f)
(let ((y f))
(set-object-property! y 'name 'f)
(set-object-property! y 'module (module-name (current-module)))))
(define-syntax-rule (define-named-object f x)
(define f
(let ((y x))
......
......@@ -87,8 +87,8 @@ POST_INSTALL = :
NORMAL_UNINSTALL = :
PRE_UNINSTALL = :
POST_UNINSTALL = :
build_triplet = x86_64-unknown-linux-gnu
host_triplet = x86_64-unknown-linux-gnu
build_triplet = x86_64-pc-linux-gnu
host_triplet = x86_64-pc-linux-gnu
subdir = logic/guile-log/src
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
......@@ -214,7 +214,7 @@ AR = ar
AUTOCONF = ${SHELL} /home/stis/src/guile-log/build-aux/missing autoconf
AUTOHEADER = ${SHELL} /home/stis/src/guile-log/build-aux/missing autoheader
AUTOMAKE = ${SHELL} /home/stis/src/guile-log/build-aux/missing automake-1.15
AWK = gawk
AWK = mawk
CC = gcc
CCDEPMODE = depmode=gcc3
CFLAGS = -g -O2
......@@ -233,11 +233,11 @@ EGREP = /bin/grep -E
EXEEXT =
FGREP = /bin/grep -F
GREP = /bin/grep
GUILD = /usr/local/bin/guild
GUILE = /usr/local/bin/guile
GUILE_CONFIG = /usr/local/bin/guile-config
GUILD = /home/stis/guile/meta/guild
GUILE = /home/stis/guile/meta/guile
GUILE_CONFIG = /home/stis/guile/meta/guile-config
GUILE_EFFECTIVE_VERSION = 2.2
GUILE_TOOLS = /usr/local/bin/guild
GUILE_TOOLS = /home/stis/guile/meta/guild
INSTALL = /usr/bin/install -c
INSTALL_DATA = ${INSTALL} -m 644
INSTALL_PROGRAM = ${INSTALL}
......@@ -251,6 +251,7 @@ LIBTOOL = $(SHELL) $(top_builddir)/libtool
LIPO =
LN_S = ln -s
LTLIBOBJS =
LT_SYS_LIBRARY_PATH =
MAKEINFO = ${SHELL} /home/stis/src/guile-log/build-aux/missing makeinfo
MANIFEST_TOOL = :
MKDIR_P = /bin/mkdir -p
......@@ -291,22 +292,22 @@ am__quote =
am__tar = $${TAR-tar} chof - "$$tardir"
am__untar = $${TAR-tar} xf -
bindir = ${exec_prefix}/bin
build = x86_64-unknown-linux-gnu
build = x86_64-pc-linux-gnu
build_alias =
build_cpu = x86_64
build_os = linux-gnu
build_vendor = unknown
build_vendor = pc
builddir = .
datadir = ${datarootdir}
datarootdir = ${prefix}/share
docdir = ${datarootdir}/doc/${PACKAGE_TARNAME}
dvidir = ${docdir}
exec_prefix = ${prefix}
host = x86_64-unknown-linux-gnu
host = x86_64-pc-linux-gnu
host_alias =
host_cpu = x86_64
host_os = linux-gnu
host_vendor = unknown
host_vendor = pc
htmldir = ${docdir}
includedir = ${prefix}/include
infodir = ${datarootdir}/info
......
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