diff options
| -rw-r--r-- | modules/language/python/module/pickle.scm | 20 | ||||
| -rw-r--r-- | modules/language/python/persist.scm | 72 |
2 files changed, 62 insertions, 30 deletions
diff --git a/modules/language/python/module/pickle.scm b/modules/language/python/module/pickle.scm new file mode 100644 index 0000000..8c14e8e --- /dev/null +++ b/modules/language/python/module/pickle.scm @@ -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)) diff --git a/modules/language/python/persist.scm b/modules/language/python/persist.scm index cf0f7c2..4005220 100644 --- a/modules/language/python/persist.scm +++ b/modules/language/python/persist.scm @@ -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))) @@ -32,10 +33,12 @@ 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 @@ -48,22 +51,29 @@ (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) @@ -71,22 +81,24 @@ 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 () |