diff options
Diffstat (limited to 'modules')
-rw-r--r-- | modules/language/python/bytes.scm | 41 | ||||
-rw-r--r-- | modules/language/python/dict.scm | 24 | ||||
-rw-r--r-- | modules/language/python/list.scm | 13 | ||||
-rw-r--r-- | modules/language/python/module/copy.scm | 7 | ||||
-rw-r--r-- | modules/language/python/module/string.scm | 2 | ||||
-rw-r--r-- | modules/language/python/number.scm | 20 | ||||
-rw-r--r-- | modules/language/python/persist.scm | 84 | ||||
-rw-r--r-- | modules/language/python/set.scm | 21 | ||||
-rw-r--r-- | modules/language/python/string.scm | 13 | ||||
-rw-r--r-- | modules/language/python/tuple.scm | 10 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 81 |
11 files changed, 279 insertions, 37 deletions
diff --git a/modules/language/python/bytes.scm b/modules/language/python/bytes.scm index 7700a00..1a0a8af 100644 --- a/modules/language/python/bytes.scm +++ b/modules/language/python/bytes.scm @@ -10,6 +10,7 @@ #:use-module (language python exceptions) #:use-module (language python list) #:use-module (language python hash) + #:use-module (language python persist) #:export (<py-bytes> pybytes-listing bytes bytearray bytes->bytevector <py-bytearray> pybytesarray-listing)) @@ -24,6 +25,42 @@ (define-class <py-bytes> () bytes) (define-class <py-bytearray> () n vec) +(name-object <py-bytes>) +(name-object <py-bytearray>) + +(cpit <py-bytes> (o (lambda (o n l) + (slot-set! o 'bytes + (let lp ((l l) (i 0) (b (b-make n))) + (if (pair? l) + (b-set! b i (car l)) + (lp (cdr l) (+ i 1) b))))) + (let* ((b (slot-ref o 'bytes)) + (n (b-len b))) + (list + n + (let lp ((i 0)) + (if (< i n) + (cons (b-ref b i) (lp (+ i 1))) + '())))))) + +(cpit <py-bytearray> (o (lambda (o n m l) + (slot-set! o 'n m) + (slot-set! o 'vec + (let lp ((l l) (i 0) (b (b-make n))) + (if (pair? l) + (b-set! b i (car l)) + (lp (cdr l) (+ i 1) b))))) + (let* ((b (slot-ref o 'vec)) + (n (b-len b))) + (list + n + (slot-ref o 'n) + (let lp ((i 0)) + (if (< i n) + (cons (b-ref b i) (lp (+ i 1))) + '())))))) + + (define-method (b-get (o <bytevector>)) o) (define-method (b-get (o <py-bytes>)) @@ -81,6 +118,8 @@ (lp (- i 1) (cdr r))) (slot-set! self 'bytes bytes))))))))))) +(name-object bytes) + (define-python-class bytearray (<py-bytearray>) (define __init__ (case-lambda @@ -125,6 +164,8 @@ (slot-set! self 'vec bytes) (slot-set! self 'n (b-len bytes))))))))))))) +(name-object bytearray) + (define-syntax-rule (define-py (f o . u) code ...) (begin (define-method (f (o <bytevector>) . u) code ...) diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm index b9ab116..fe18583 100644 --- a/modules/language/python/dict.scm +++ b/modules/language/python/dict.scm @@ -6,6 +6,7 @@ #:use-module (language python def) #:use-module (language python for) #:use-module (language python exceptions) + #:use-module (language python persist) #:use-module (ice-9 match) #:use-module (ice-9 control) #:use-module (oop goops) @@ -39,6 +40,27 @@ (define H (hash 1333674836 complexity)) (define-class <py-hashtable> () t h n) + +(name-object <py-hashtable>) + +(cpit <py-hashtable> + (o (lambda (o h n a) + (slot-set! o 'h h) + (slot-set! o 'n n) + (slot-set! o 't + (let ((t (make-hash-table))) + (let lp ((a a)) + (if (pair? a) + (begin + (py-hash-set! t (caar a) (cdar a)) + (lp (cdr a))))) + t))) + (let ((t (slot-ref o 't))) + (list + (slot-ref o 'h) + (slot-ref o 'n) + (hash-fold (lambda (k v s) (cons (cons k v) s)) '() t))))) + (define (make-py-hashtable) (let* ((o (make <py-hashtable>)) (t (make-hash-table)) @@ -503,6 +525,8 @@ (slot-ref x 't))))))) __init__))) +(name-object dict) + (define (pyhash-listing) (let ((l (to-pylist (map symbol->string diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm index 5f4fbb7..dc63298 100644 --- a/modules/language/python/list.scm +++ b/modules/language/python/list.scm @@ -10,6 +10,7 @@ #:use-module (language python for) #:use-module (language python try) #:use-module (language python exceptions) + #:use-module (language python persist) #:export (to-list to-pylist <py-list> pylist-append! pylist-slice pylist-subset! pylist-reverse! @@ -24,6 +25,14 @@ (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) (define-class <py-list> () vec n) +(name-object <py-list>) + +(cpit <py-list> (o (lambda (o n l) + (slot-set! o 'n n) + (slot-set! o 'vec (list->vector l))) + ((@ (guile) list) + (slot-ref o 'n) + (vector->list (slot-ref o 'vec))))) (define-method (pylist-delete! (o <py-list>) k) (let* ((n (slot-ref o 'n)) @@ -841,7 +850,9 @@ (__init__ self) (for ((i : it)) () (pylist-append! self i)))))) __init__))) - + +(name-object list) + (define pylist list) (define-method (py-class (o <py-list>) list)) diff --git a/modules/language/python/module/copy.scm b/modules/language/python/module/copy.scm new file mode 100644 index 0000000..2673e7e --- /dev/null +++ b/modules/language/python/module/copy.scm @@ -0,0 +1,7 @@ +(define-module (language python module copy) + #:export (Error copy deepcopy)) + +(define Error 'CopyError) + +(define (copy x) ((@@ (logic guile-log persistance) copy) x)) +(define (deepcopy x) ((@@ (logic guile-log persistance) deep-copy) x)) diff --git a/modules/language/python/module/string.scm b/modules/language/python/module/string.scm index 08dabcd..d867226 100644 --- a/modules/language/python/module/string.scm +++ b/modules/language/python/module/string.scm @@ -377,4 +377,6 @@ (else (throw TypeError "conversion" conversion)))))) +(define (ascii x) (bytes x)) + (set! (@@ (language python string) formatter) (Formatter)) diff --git a/modules/language/python/number.scm b/modules/language/python/number.scm index 521cc42..c81570d 100644 --- a/modules/language/python/number.scm +++ b/modules/language/python/number.scm @@ -5,6 +5,7 @@ #:use-module (language python list) #:use-module (language python try) #:use-module (language python exceptions) + #:use-module (language python persist) #:export (py-int py-float py-complex py-/ py-logand py-logior py-logxor py-abs py-trunc py-lshift py-rshift py-mod py-floordiv py-round @@ -19,6 +20,17 @@ (define-class <py-float> () x) (define-class <py-complex> () x) +(name-object <py-int>) +(name-object <py-float>) +(name-object <py-complex>) + +(define-syntax-rule (mk <py-int>) + (cpit <py-int> (o (lambda (o x) (slot-set! o 'x x)) (list (slot-ref o 'x))))) + +(mk <py-int>) +(mk <py-float>) +(mk <py-complex>) + (define-syntax-rule (b0 op) (begin (define-method (op (o1 <py-int>) o2) @@ -235,6 +247,8 @@ (__init__ self (string->number n k)))))) __init__))) +(name-object int) + (define (proj? x) (if (number? x) x @@ -273,7 +287,9 @@ (aif it (slot-ref n '__float__) (slot-set! self 'x it) (raise ValueError "could not make float from " n))))))))) - + +(name-object float) + (define-python-class py-complex (<py-complex>) (define __init__ (case-lambda @@ -297,6 +313,8 @@ (else (raise ValueError "could not make complex from " n m))))))) +(name-object py-complex) + (define-method (py-class (o <integer> )) int) (define-method (py-class (o <real> )) float) (u0 py-class) diff --git a/modules/language/python/persist.scm b/modules/language/python/persist.scm index ac7d7af..cf0f7c2 100644 --- a/modules/language/python/persist.scm +++ b/modules/language/python/persist.scm @@ -1,31 +1,63 @@ (define-module (language python persist) - #:export ()) + #: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) + #:export (reduce cp red cpit)) -(define-method (pcopyable (<p> o)) #t) -(define-method (deep_pcopyable (<p> o)) #t) +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) -(define-method (pcopy (<p> o)) +(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) + (list #:reduce + (let ((cl (class-of o))) + (lambda () (make cl))) + (reduce o))) + +(define-method (pcopy (o <p>)) (list #:obj - (aif it (get o '__copy__) + (aif it (ref o '__copy__) (it) - (copy o)))) + (cp o)))) -(define-method (deep-pcopy (<p> o) p?) - (aif it (and p? (get o '__deepcopy__)) +(define-method (deep-pcopy (o <p>) p?) + (aif it (and p? (ref o '__deepcopy__)) (list #:obj (it)) - (list #:reduce - (make (class-of o)) - (reduce o)))) + (red o))) (define-method (reduce o) '()) -(define-method (reduce (<p> 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)))))) + (lambda (x) (hash-set! h (car x) (cdr x))) + args))) (list (hash-fold (lambda (k v s) (cons (cons k v) s)) @@ -33,7 +65,12 @@ (slot-ref o 'h)))) (next-method))) -(define-method (reduce (<pf> o)) +(define (fold f s l) + (if (pair? l) + (fold f (f (car l) s) (cdr l)) + s)) + +(define-method (reduce (o <pf>)) (cons* (cons (lambda (o n args) @@ -48,3 +85,22 @@ (list (slot-ref o 'n) (vhash->assoc (slot-ref o 'h)))) (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)))))))) + + + + diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm index e9d7c63..25b02d7 100644 --- a/modules/language/python/set.scm +++ b/modules/language/python/set.scm @@ -7,9 +7,26 @@ #:use-module (language python try) #:use-module (language python list) #:use-module (language python yield) - #:export(py-set)) + #:use-module (language python persist) + #:export (py-set)) (define-class <set> () dict) +(name-object <set>) + +(cpit <set> + (o (lambda (o a) + (slot-set! o 'dict + (let ((h (make-py-hashtable))) + (let lp ((a a)) + (if (pair? a) + (begin + (h-set! h (caar a) (cdar a)) + (lp (cdr a)))))))) + (list + (hash-fold (lambda (k v s) (cons (cons k v) s)) + '() + (slot-ref o 'dict))))) + (define miss (list 'miss)) @@ -213,4 +230,6 @@ (yield k) (values)))))) +(name-object set) + (define py-set set) diff --git a/modules/language/python/string.scm b/modules/language/python/string.scm index 8d6d642..52aa2f1 100644 --- a/modules/language/python/string.scm +++ b/modules/language/python/string.scm @@ -7,6 +7,7 @@ #:use-module (language python list) #:use-module (language python exceptions) #:use-module (language python for) + #:use-module (language python persist) #:export (py-format py-capitalize py-center py-endswith py-expandtabs py-find py-rfind py-isalnum py-isalpha py-isdigit py-islower @@ -22,6 +23,10 @@ (define-class <py-string> () str) +(name-object <py-string>) + +(cpit <py-string> (o (lambda (o s) (slot-set! o 'str s)) + (list (slot-ref o 'str)))) (define-syntax-rule (define-py (f n o . u) code ...) (begin @@ -487,7 +492,13 @@ ((is-a? s <py-string>) (slot-set! self 'str (slot-ref s 'src))) ((is-a? s <string>) - (slot-set! self 'str s))))))) + (slot-set! self 'str s)))))) + + (define __repr__ + (lambda (self) + (slot-ref self 'str)))) + +(name-object string) (define pystring string) diff --git a/modules/language/python/tuple.scm b/modules/language/python/tuple.scm index 5a36b4b..3ca4281 100644 --- a/modules/language/python/tuple.scm +++ b/modules/language/python/tuple.scm @@ -3,10 +3,18 @@ #:use-module (oop pf-objects) #:use-module (language python hash) #:use-module (language python for) + #:use-module (language python persist) #:export (tuple <py-tuple> defpair)) (define-class <py-tuple> () l) +(name-object <py-tuple>) +(cpit <py-tuple> + (o (lambda (o l) + (slot-set! o 'l (map (lambda (x) x) l))) + (list + (slot-ref o 'l)))) + (define-method (py-hash (o <py-tuple>)) (py-hash (slot-ref o 'l))) (define-method (py-class (o <py-tuple>) tuple)) (define-method (py-equal? (o1 <py-tuple>) o2) (equal? (slot-ref o1 'l) o2)) @@ -28,6 +36,8 @@ (define __repr__ (lambda (self) (format #f "~a" (slot-ref self 'l))))) +(name-object tuple) + (define-syntax-rule (defpair (f o . u) code ...) (begin (define-method (f (o <pair>) . u) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 4ed5680..15aad1f 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -2,7 +2,8 @@ #:use-module (oop goops) #:use-module (ice-9 vlist) #:use-module (ice-9 match) - #:replace (equal?) + #:use-module (logic guile-log persistance) + #:replace (equal?) #:export (set ref make-p <p> <py> <pf> <pyf> <property> call with copy fset fcall put put! pcall pcall! get fset-x pyclass? @@ -55,6 +56,12 @@ explicitly tell it to not update etc. (define-class <property> () get set del) +(name-object <p>) +(name-object <pf>) +(name-object <py>) +(name-object <pyf>) +(name-object <property>) + (define (get-dict self name parents) (aif it (ref self '__prepare__) (it self name parents) @@ -660,22 +667,48 @@ explicitly tell it to not update etc. ;; Let's make an object essentially just move a reference ;; the make class and defclass syntactic sugar -(define-syntax-rule (mk-p-class name - parents - (ddef dname dval) - ...) - (let () - (define name - (letruc ((dname dval) ...) - (make-p-class 'name - parents - (lambda (dict) - (pylist-set! dict 'dname dname) - ... - (values))))) - - - name)) +(define-syntax mk-p-class + (lambda (x) + (syntax-case x () + ((_ name parents (ddef dname dval) ...) + (with-syntax (((ddname ...) + (map (lambda (dn) + (datum->syntax + #'name + (string->symbol + (string-append + (symbol->string + (syntax->datum #'name)) + "-" + (symbol->string + (syntax->datum dn)))))) + #'(dname ...))) + (nname (datum->syntax + #'name + (string->symbol + (string-append + (symbol->string + (syntax->datum #'name)) + "-goops-class"))))) + #'(let () + (define name + (letruc ((dname dval) ...) + (make-p-class 'name + parents + (lambda (dict) + (pylist-set! dict 'dname dname) + ... + (values))))) + + (begin + (module-define! (current-module) 'ddname (ref name 'dname)) + (name-object ddname)) + ... + + (module-define! (current-module) 'nname (ref name '__goops__)) + (name-object nname) + + name)))))) (define-syntax-rule (def-p-class name . l) (define name (mk-p-class name . l))) @@ -731,8 +764,15 @@ explicitly tell it to not update etc. (define-syntax-rule (define-python-class name (parents ...) code ...) (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...))) -(define-syntax-rule (make-python-class name (parents ...) code ...) - (mk-p-class name (arglist->pkw (list parents ...)) code ...)) +(define-syntax make-python-class + (lambda (x) + (syntax-case x () + ((_ name (parents ...) code ...) + #'(let* ((cl (mk-p-class name + (arglist->pkw (list parents ...)) + code ...))) + cl))))) + (define (kind x) (and (is-a? x <p>) @@ -952,3 +992,6 @@ explicitly tell it to not update etc. (set type '__class__ type) (set! object (make-python-class object ())) + +(name-object type) +(name-object object) |