1 files changed, 114 insertions, 0 deletions
diff --git a/modules/language/python/#persist.scm# b/modules/language/python/#persist.scm#
new file mode 100644
index 0000000..4ee46fc
--- /dev/null
+++ b/modules/language/python/#persist.scm#
@@ -0,0 +1,114 @@
+(define-module (language python persist)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 pretty-print)
+  #: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
+			 name-object-deep)
+  #:export (reduce cp red cpit))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define (vhash->assoc v)
+  (let ((t (make-hash-table)))
+    (vhash-fold
+     (lambda (k v s)
+       (if (hash-ref t k)
+	   s
+	   (begin
+	     (hash-set! t k #t)
+	     (cons (cons k v) s))))
+     '() v)))
+
+(define-method (pcopyable?      (o <p>)) #t)
+(define-method (deep-pcopyable? (o <p>)) #t)
+
+(define (cp o)
+  (match (red o)
+	 ((#:reduce mk f)
+	  (let ((oo (mk)))
+	    (for-each (lambda (x) (apply (car x) oo (cdr x))) f)
+	    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
+	(aif it (ref o '__copy__)
+	     (it)
+	     (cp o))))
+
+(define-method (deep-pcopy (o <p>) p?)
+  (aif it (and p? (ref o '__deepcopy__))
+       (list #:obj  (it))
+       (red o)))
+
+(define first (make-fluid #f))
+(define-method (reduce o) '())
+(define-method (reduce (o <p>))
+  (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)
+      (fold f (f (car l) s) (cdr l))
+      s))
+
+(define-method (reduce (o <pf>))
+  (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 ()
+      ((_ <c> (o lam a))
+       #'(begin    
+	   (define-method (pcopyable?      (o <c>)   ) #t)
+	   (define-method (deep-pcopyable? (o <c>)   ) #t)
+	   (define-method (pcopy           (o <c>)   ) (cp o))
+	   (define-method (deep-pcopy      (o <c>) p?) (red o))
+	   (define-method (reduce          (o <c>)   )
+	     (cons*
+	      (cons lam a)
+	      (next-method))))))))