pickle
[software/python-on-guile.git] / modules / language / python / persist.scm
index cf0f7c29f6cb63d9b46683ec2620722c0ac6a5b4..4005220f74f3d41e47735da47bf52936a8b4def1 100644 (file)
@@ -5,7 +5,8 @@
   #:use-module (oop goops)
   #:use-module (oop pf-objects)
   #:use-module (logic guile-log persistance)
-  #:re-export(pcopyable? deep-pcopyable? pcopy deep-pcopy name-object)
+  #:re-export(pcopyable? deep-pcopyable? pcopy deep-pcopy name-object
+                        name-object-deep)
   #:export (reduce cp red cpit))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
            oo))))
 
 (define (red o)
+  (fluid-set! first #t)
   (list #:reduce
        (let ((cl (class-of o)))
          (lambda () (make cl)))                
        (reduce o)))
+  
 
 (define-method (pcopy (o <p>))
   (list #:obj
        (list #:obj  (it))
        (red o)))
 
+(define first (make-fluid #f))
 (define-method (reduce o) '())
 (define-method (reduce (o <p>))
-  (cons*
-   (cons
-    (lambda (o args)
-      (let ((h (make-hash-table)))
-       (slot-set! o 'h h)
-       (for-each
-        (lambda (x) (hash-set! h (car x) (cdr x)))
-        args)))
-    (list
-     (hash-fold
-      (lambda (k v s) (cons (cons k v) s))
-      '()
-      (slot-ref o 'h))))
-   (next-method)))
+  (if (fluid-ref first)
+      (begin
+       (fluid-set! first #f)
+       (cons
+        (aif it (ref o '__reduce__)
+             (it)
+             (cons
+              (lambda (o args)
+                (let ((h (make-hash-table)))
+                  (slot-set! o 'h h)
+                  (for-each
+                   (lambda (x) (hash-set! h (car x) (cdr x)))
+                   args)))
+              (list
+               (hash-fold
+                (lambda (k v s) (cons (cons k v) s))
+                '()
+                (slot-ref o 'h)))))
+        (next-method)))
+      (next-method)))
 
 (define (fold f s l)
   (if (pair? l)
       s))
 
 (define-method (reduce (o <pf>))
-  (cons*
-   (cons
-    (lambda (o n args)
-      (slot-set! o 'size n)
-      (slot-set! o 'n    n)
-      (let ((h
-            (fold            
-             (lambda (k v s) (vhash-assoc k v s))
-             vlist-null
-             args)))
-       (slot-set! o 'h h)))
-    (list (slot-ref o 'n) (vhash->assoc (slot-ref o 'h))))
-   (next-method)))
+  (if (fluid-ref first)
+      (begin
+       (fluid-set! first #f)
+       (cons*
+        (cons
+         (lambda (o n args)
+           (slot-set! o 'size n)
+           (slot-set! o 'n    n)
+           (let ((h
+                  (fold              
+                   (lambda (k v s) (vhash-assoc k v s))
+                   vlist-null
+                   args)))
+             (slot-set! o 'h h)))
+         (list (slot-ref o 'n) (vhash->assoc (slot-ref o 'h))))
+        (next-method)))
+      (next-method)))
      
-
-
 (define-syntax cpit
   (lambda (x)
     (syntax-case x ()