pickle
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 21 Feb 2018 14:23:59 +0000 (15:23 +0100)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 21 Feb 2018 14:23:59 +0000 (15:23 +0100)
modules/language/python/module/pickle.scm [new file with mode: 0644]
modules/language/python/persist.scm

diff --git a/modules/language/python/module/pickle.scm b/modules/language/python/module/pickle.scm
new file mode 100644 (file)
index 0000000..8c14e8e
--- /dev/null
@@ -0,0 +1,20 @@
+(define-module (language python module pickle)
+  #:use-module (language python persist)
+  #:export (dump dumps load loads name nameDeep))
+
+(define* (dump obj file #:key (protocol #f) (fix_imports #t))
+  ((@@ (logic guile-log persistance) dump) obj file))
+
+(define* (dumps obj #:key (protocol #f) (fix_imports #t))
+  ((@@ (logic guile-log persistance) dumps) obj))
+
+(define* (load file
+              #:key (fix_imports #t) (encodeing "ASCII") (errors "strict"))
+  ((@@ (logic guile-log persistance) load) file))
+
+(define* (loads s
+              #:key (fix_imports #t) (encodeing "ASCII") (errors "strict"))
+  ((@@ (logic guile-log persistance) loads) s))
+
+(define-syntax-rule (name x)     (name-object      x))
+(define-syntax-rule (nameDeep x) (name-object-deep x))
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 ()