struct serializing works

parent 72bee95b
......@@ -69,7 +69,7 @@ Version 0.6, TODO
* GC of the (almost) unreachable tail of a stream (all)
* Multi threading capabilities (all)
* Sandboxing (prolog)
* More general functional hashmps (all) DONE
* More general functional hashmaps (all) DONE
* Ordinary hash maps (all)
* Faster compilation (prolog)
* Better compilation errors (prolog)
......
......@@ -134,6 +134,9 @@
gp-make-null-procedure
gp-fill-null-procedure
gp-make-struct
gp-set-struct
))
;; Tos silence the compiler, those are fetched from the .so file
......
......@@ -12,6 +12,20 @@
persist-ref
test))
(define (default-print-func struct port)
(format port "<pre-struct>"))
(define default-struct
(make-vtable "pw" default-print-func))
(define (struct->data s)
(let lp ((n 0) (r (list (struct-vtable s))))
(catch #t
(lambda ()
(lp (+ n 1) (cons (struct-ref s n) r)))
(lambda x
(reverse r)))))
(define default-code (program-code format))
(define-syntax-rule (aif (it) p x y) (let ((it p)) (if it x y)))
......@@ -52,6 +66,7 @@
(define gp-pair 8)
(define atom 9)
(define code 10)
(define standard-vtable 11)
(define set-gp-var 20)
(define set-var 21)
......@@ -101,6 +116,10 @@
(let ((v (cons 0 0)))
(log 'reg-obj i v)))
(((? (M struct)) i n)
(let ((v (gp-make-struct default-struct n)))
(log 'reg-obj i v)))
(((? (M vector)) i n)
(let ((v (make-vector n)))
(log 'reg-obj i v)))
......@@ -109,8 +128,6 @@
(let ((v (gp-make-null-procedure n default-code)))
(log 'reg-obj i v)))
(((? (M struct))) 1)
(((? (M named)) i globdata)
(call-with-values (lambda () (log 'get-global globdata))
(lambda (path name)
......@@ -126,9 +143,14 @@
"module ~a is not present at unserializing" path)))))
(((? (M standard-vtable)) i)
(log 'reg-obj i <standard-vtable>))
(((? (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)
a)
......@@ -163,6 +185,14 @@
(vector-set! v n x)
(lp (cdr l) (+ n 1)))))))
(((? (M set-struct)) i l)
(let ((v (log 'rev-lookup i)))
(let lp ((l l) (n 0) (r '()))
(if (pair? l)
(let ((x (log 'rev-lookup (car l))))
(lp (cdr l) (+ n 1) (cons x r)))
(gp-set-struct v (reverse r))))))
(((? (M set-procedure)) i interface addr l)
(let ((proc
(log 'rev-lookup i))
......@@ -319,6 +349,10 @@
(mk-obj n i
`(,procedure ,n ,j)))
((make-struct)
(mk-obj n i
`(,struct ,n ,j)))
((make-vector)
(mk-obj n i
`(,vector ,n ,j)))
......@@ -338,6 +372,8 @@
(update `(,set-fluid ,i ,j)))
((set-accessor)
(update `(,set-accessor ,i ,j)))
((set-struct)
(update `(,set-struct ,i ,j)))
((set-vector)
(update `(,set-vector ,i ,j)))))
......@@ -408,6 +444,10 @@
(mk-atom i x
`(,code ,i ,(code-to-int x))))
((make-standard-vtable)
(mk-obj i x
`(,standard-vtable ,i)))
((make-gp-var)
(mk-obj i x
`(,gp-var ,i)))
......@@ -426,12 +466,7 @@
((make-gp-pair)
(mk-obj i x
`(,gp-pair ,i)))
((make-struct)
(mk-obj i x
`(,struct ,i))))))))
`(,gp-pair ,i))))))))
(define (register-tag log tag x)
(let ((i (persist log x)))
......@@ -484,6 +519,10 @@
(j (persist log v)))
(log 'set-gp-var i id j)))))
(define (make-standard-vtable)
(let ((i (mk-name 'make-standard-vtable x)))
i))
(define (make-a-pair)
(let ((i (mk-name 'make-pair x)))
(do-if-deep x i
......@@ -500,6 +539,13 @@
(log 'set-accessor obj data)
i)))
(define (make-a-struct)
(let* ((l (struct->data x))
(i (mk-name 'make-struct x (- (length l) 1))))
(do-if-deep x i
(let ((l (map (lambda (x) (persist log x)) l)))
(log 'set-struct i l)))))
(define (make-a-vector)
(let* ((n (vector-length x))
(i (mk-name 'make-vector x n)))
......@@ -548,6 +594,8 @@
=>
(lambda (y)
(mk (lambda () (make-an-access x y)))))
((eq? x <standard-vtable>)
(mk make-standard-vtable))
((gp? x)
(mk make-a-gp-var))
((variable? x)
......@@ -558,7 +606,8 @@
(mk make-a-pair))
((vector? x)
(mk make-a-vector))
((struct? x))
((struct? x)
(mk make-a-struct))
((procedure? x)
(mk make-a-procedure))
((code-to-int x)
......
......@@ -3682,6 +3682,40 @@ SCM_DEFINE(gp_fill_null_procedure, "gp-fill-null-procedure", 3, 0, 0, (SCM proc,
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_make_struct, "gp-make-struct", 2, 0, 0,
(SCM vtable_data, SCM n),
"")
#define FUNC_NAME s_gp_make_struct
{
SCM ret;
int i,nn = scm_to_int(n);
ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, scm_to_int(n) + 2);
SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
for(i = 0; i < nn; i++)
GP_GETREF(ret)[i+2] = SCM_UNSPECIFIED;
return ret;
}
#undef FUNC_NAME
SCM_DEFINE(gp_set_struct, "gp-set-struct", 2, 0, 0,
(SCM s, SCM l),
"")
#define FUNC_NAME s_gp_set_struct
{
int i;
SCM *v = GP_GETREF(s);
SCM vtable = SCM_CAR(l);
l = SCM_CDR(l);
v[0] = SCM_PACK(((scm_t_bits) SCM_STRUCT_DATA(vtable)) | scm_tc3_struct);
v = GP_GETREF(v[1]);
for(i=0;SCM_CONSP(l);l=SCM_CDR(l),i++)
{
v[i] = SCM_CAR(l);
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#include "indexer/indexer.c"
......
......@@ -157,3 +157,6 @@ SCM_API SCM gp_int_to_code(SCM x);
SCM_API SCM gp_code_to_int(SCM x);
SCM_API SCM gp_make_null_procedure(SCM n, SCM def);
SCM_API SCM gp_fill_null_procedure(SCM proc, SCM addr, SCM l);
SCM_API SCM gp_set_struct(SCM a, SCM b);
SCM_API SCM gp_make_struct(SCM a, SCM b);
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