initial db commit

parent d696cbc1
(define-module (logic guile-log db)
#:use-module (logic guile-log db db)
#:export ())
;; VLIST
(define vlist-base (@@ (logic guile-log code-load) clist-base))
(define vlist-offset (@@ (logic guile-log code-load) clist-offset))
#|
elts[0] = first;
elts[1] = base;
elts[2] = my_scm_from_ulong(COMB(offset, seq));
elts[3] = my_scm_from_ulong(COMB(size, thr));
elts[4] = my_scm_from_int(0);
|#
;; TABLE
(define (table-elm x i) (vector-ref (vector-ref x 0) i))
(define (table-key x i) (vector-ref (vector-ref x 0) i))
(define (table-val x i) (vector-ref (vector-ref x 0) i))
(define (table-next x) (vector-ref x 1))
(define (table-next-offset x) (logand (vector-ref x 2) #xffffffff))
(define (table-size x) (logand (vector-ref x 3) #xffffffff))
(define (data->string x)
(with-output-to-string
(lambda () (write x))))
;;Strings
(define (add-strings x db)
(let ((strings (slot-ref db 'strings)))
(aif it (hash-ref strings x)
it
(let ((id (db-write-string x db)))
(hash-set! strings x id)
id))))
;;module
(define (add-module x db)
(if x
(let ((modules (slot-ref db 'modules)))
(aif it (hash-ref modules x)
it
(let ((id (db-write-module (data->string x) db)))
(hash-set! modules x id)
id)))
0))
;; Data
(define (add-data db x)
(define variables (make-hash-table))
(define (make-data x)
(cond
((pair? x)
`(c ,(make-data (car x)) ,(make-data (cdr x))))
((vector? x)
(if (= (length x) 1)
`(a ,(make-data (vector-ref x 0)))
`(b ,(make-data (vector-ref x 0)))))
((string? x)
`(c ,(add-string x db)))
((symbol? x)
`(d ,(add-string (symbol->string x))))
((keyword? x)
`(e ,(add-string (keyword->string x))))
((procedure? x)
`(f ,(add-string (symbol->string (procedure-name x)))
,(add-module (procedure-property x 'module #f))))
(else
x)))
(data->string (make-data x)))
;; VLists
(define (add-vlist db vlist)
(let ((vlists (slot-ref db 'vlists)))
(aif it (hash-ref vlists vlist)
it
(let* ((tableid (add-table-l sb
(vlist-base vlist)
(vlist-offset vlist)))
(vid (db-write-vlist db tableif (vlist-offset vlist))))
(hash-set! vlists vlist vid)
vid))))
(define (add-vhash db vlist)
(let ((vlists (slot-ref db 'vhash)))
(aif it (hash-ref vlists vlist)
it
(let* ((tableid (add-table sb
(vlist-base vlist)
(vlist-offset vlist)))
(vid (db-write-vhash db tableif (vlist-offset vlist))))
(hash-set! vlists vlist vid)
vid))))
(define (add-table db table offset)
(let* ((tables (slot-ref db 'tables))
(tn (table-size table)))
(aif it (hash-ref tables table)
(let ((dbtn (list-ref it 1)))
(if (= dbtn tn)
(car it)
(begin
(fill-table db table (car it) dbtn tn)
(hash-set! tables table (list (car it) tn))
(car it))))
(let ((new-table-id
(add-table db (table-next table) (table-next-offset table)))
(id (db-write-table db tn)))
(fill-table db table id 0 tn)
(hash-set! tables table (list id tn))
id))))
(define (add-table-l db table offset)
(let* ((tables (slot-ref db 'tables))
(tn (table-size table)))
(aif it (hash-ref tables table)
(let ((dbtn (list-ref it 1)))
(if (= dbtn tn)
(car it)
(begin
(fill-table-l db table (car it) dbtn tn)
(hash-set! tables table (list (car it) tn))
(car it))))
(let ((new-table-id
(add-table db (table-next table) (table-next-offset table)))
(id (db-write-table db tn)))
(fill-table-l db table id 0 tn)
(hash-set! tables table (list id tn))
id))))
(define (fill-table db table dbtable dbtn tn)
(define diff (@@ (logic guile-log code-load) vblock-diff))
(let lp ((l (diff table dbtn)))
(if (pair? l)
(db-write-table-entry db dbtable
(add-data db (caar l))
(add-data db (cdar l)))
(lp (cdr l)))))
(define (fill-table-l db table dbtable dbtn tn)
(define diff (@@ (logic guile-log code-load) vblock-diff-l))
(let lp ((l (diff table dbtn)))
(if (pair? l)
(db-write-table-entryl db dbtable (add-data db (car l)))
(lp (cdr l)))))
;; Tree
(define (add-tree db x)
(if (vector? x)
(let ((nodes (db-nodes db)))
(aif it (hashq-ref nodes x)
(dbnode-key it)
(let ((car-key (add-tree (tree-car x) db))
(cdr-key (add-tree (tree-cdr x) db))
(var-key (add-vlist (tree-var x) db))
(str-key (add-vlist (tree-str x) db))
(atm-key (add-vlist (tree-atm x) db))
(db-node
(db-write-node car-key cdr-key var-key str-key atm-key db)))
(hashq-set! nodes x db-node)
(node-key db-node))))
0))
;; env
(define (add-env env db)
(let* ((f (vector-ref env 0))
(dyn (vector-ref env 1))
(vec (vector-ref env 2))
(tre (vector-ref env 3))
(kf (add-data db f))
(kdyn (add-dyn dyn db))
(kvec (add-vec vec db))
(ktre (add-tree tre db)))
(db-write-env kf kdyn kvec ktre)))
;; Predicate
(define (add-predicate-data f db)
(let ((env (get-env f))
(envs (db-envs db)))
(if (hash-ref envs env)
#t
(let ((key1 (add-env (car env) db))
(key2 (add-env (cdr env) db))
(key3 (db-write-pred f dir key1 key2)))
(hash-set! envs env (make-pred key3 f dir key1 key2))
key3))))
(define-module (logic guile-log db db)
#:use-module (oop goops)
(
;; Classes
DB
FileDB
;; Methods
init-db db-write-table-raw
;; procedures
db-write-string db-write-module
db-write-table-entry db-write-table-entryl db-write-table
db-write-node db-write-env db-write-pred
db-write-vlist db-write-vhash
))
(define-class DB ()
;; Data
strings string-key
modules module-key
;; vhash/vlist
tables table-key
vlists vlist-key
vhashes vhash-key
entry-key
entryl-key
nodes node-key
envs env-key
preds pred-key
)
(define (init-db (db DB) . l)
(slot-set! db 'strings (make-hash-table))
(slot-set! db 'string-key 0)
(slot-set! db 'modules (make-hash-table))
(slot-set! db 'module-key 0)
(slot-set! db 'nodes (make-hash-table))
(slot-set! db 'node-key 0)
(slot-set! db 'tables (make-hash-table))
(slot-set! db 'table-key 0)
(slot-set! db 'entry-key 0)
(slot-set! db 'entryl-key 0)
(slot-set! db 'envs (make-hash-table))
(slot-set! db 'env-key 0)
(slot-set! db 'preds (make-hash-table))
(slot-set! db 'pred-key 0)
(slot-set! db 'vlists (make-hash-table))
(slot-set! db 'vlist-key 0)
(slot-set! db 'vhashes (make-hash-table))
(slot-set! db 'vhash-key 0)
)
(define-class FileDB (DB) dir)
(define (init-db (db FileDB) dir)
(slot-set! db 'dir dir)
(next-method))
(define-method (db-write-table-raw (db DB) table . l)
(error "db-write-table on a DB is abstract"))
(define (get-path db table)
(string-append (slot-ref db 'dir) table ".dat"))
(define-method (db-write-table-raw (db FileDB) table . l)
(let ((path (get-path db table)))
(let ((fd (open-file path "a")))
(write l fd)
(close fd))))
(define (db-write-table db table keyref . x)
(let ((key (slot-ref db keyref)))
(apply db-write-table-raw db table key l)
(set! key (+ key 1))
(slot-set! db keyref key)
key))
(define (db-write-string db x)
(db-write-table db "string-table" 'string-key x))
(define (db-write-module module db)
(db-write-table db "module-table" 'module-key module))
(define (db-write-table db tn)
(db-write-table db "table-table" 'table-key tn))
(define (db-write-table-entry db dbtable ik)
(db-write-table db "entry-table" 'entry-key dbtable ik))
(define (db-write-table-entry-l db dbtable ik iv)
(db-write-table db "entryl-table" 'entryl-key dbtable ik iv))
(define (db-write-node db car-key cdr-key var-key str-key atm-key)
(db-write-table db "node-table" 'node-key car-key cdr-key var-key str-key
atm-key))
(define (db-write-env db kf kdyn kvec ktre)
(db-write-table db "env-table" 'env-key kf kdyn kvec ktre))
(define (db-write-pred db f dir key1 key2)
(db-write-table db "pred-table" 'pred-key f dir key1 key2))
(define (db-write-vlist db table offset)
(db-write-table db "vlist-table" 'vlist-key table offset))
(define (db-write-vhash db table offset)
(db-write-table db "vhash-table" 'vhash-key table offset))
......@@ -915,7 +915,7 @@ add/run * vlist *
(if (< i n)
(lp (+ i 1)
(with-fluids ((init-block-size (+ n n)))
(vlist-cons (vector-ref a i) r)))
(vlist-cons (vector-ref a i) r)))
(cons n r)))))
(define (dynlist->vlist ar dyn)
......@@ -1244,7 +1244,7 @@ add/run * vlist *
(F p cut scut
a
(tee s a
(if (vector? (tee s a ar))
(if (vector? (tee s a ar))
(vector-ref ar (car l))
(vlist-ref (cdr ar) (- (car ar) (car l) 1))))
(and #t (not more?))
......
......@@ -1819,4 +1819,32 @@ SCM setup(SCM type)
scm_cons(thread_inc, SCM_EOL))))));
}
SCM_DEFINE(vblock_diff, "vblock-diff", 2, 0, 0, (SCM block, SCM scmoffset),
"")
#define FUNC_NAME s_vblock_diff
{
int offset = scm_to_int(scmoffset);
SCM *base = dB(block);
SCM *content = dB(block_content(base));
ulong freeref = my_scm_to_ulong(block_next_free_ref(base));
ulong count = REFCOUNT(freeref);
ulong st = block_size_thr(base);
int size = SIZE(st);
SCM ret = SCM_EOL;
for(--freeref; freeref > offset; freeref--)
{
freeref = NEXTFREE(freeref);
ret = scm_cons(scm_cons(content[size + freeref],content[freeref]),
ret);
}
return scm_reverse(ret);
}
#undef FUNC_NAME
//-----------------------------------------------------------------
......@@ -37,3 +37,4 @@ SCM_API SCM scm_vhash_truncate_x(SCM vhash);
SCM_API SCM scm_set_x(SCM k, SCM v, SCM vhash);
SCM_API SCM scm_setq_x(SCM k, SCM v, SCM vhash);
SCM_API SCM scm_setv_x(SCM k, SCM v, SCM vhash);
SCM_API SCM vblock_diff(SCM block, SCM scmoffset);
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