diff options
Diffstat (limited to 'modules')
-rw-r--r-- | modules/language/python/for.scm | 4 | ||||
-rw-r--r-- | modules/language/python/module/python.scm | 2 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 124 |
3 files changed, 73 insertions, 57 deletions
diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm index f43b0c1..ab077db 100644 --- a/modules/language/python/for.scm +++ b/modules/language/python/for.scm @@ -132,6 +132,10 @@ (else x))) +(set! (@@ (oop pf-objects) hashforeach) + (lambda (f d) + (for ((k v : d)) () (f k v)))) + #; (pk (for c ((x : (gen '(1 2 3)))) ((s 0)) diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index 2c08f55..bd68841 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -35,7 +35,7 @@ SyntaxError len dir next dict None property range tuple bytes bytearray eval locals globals - compile exec + compile exec type ) #:export (print repr complex float int diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index a72d360..d5e9e5f 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -9,8 +9,9 @@ def-p-class mk-p-class make-p-class define-python-class get-type py-class object-method class-method static-method - py-super-mac py-super py-equal? - *class* *self* + py-super-mac py-super py-equal? + *class* *self* type pyobject? pytype? + type object )) #| Python object system is basically syntactic suger otop of a hashmap and one @@ -51,28 +52,14 @@ explicitly tell it to not update etc. (hash-set! h '__class__ x) (slot-set! o 'h h))) (else #f)) - (values)) + (values)) -(define-method (get-dict (self <pyf>) name parents) +(define (get-dict self name parents) (aif it (ref self '__prepare__) (it self name parents) - (make (kwclass->class kw <pyf>)))) - -(define-method (get-dict (self <py>) name parents) - (aif it (ref self '__prepare__) - (it self name parents) - (make (kwclass->class kw <py>)))) - -(define-method (get-dict (self <pf>) name parents) - (aif it (ref self '__prepare__) - (it self name parents) - (make (kwclass->class kw <pf>)))) - -(define-method (get-dict (self <p>) name parents) - (aif it (ref self '__prepare__) - (it self name parents) - (make (kwclass->class kw <p>)))) + (make-hash-table))) +(define (hashforeach a b) (values)) (define (new-class meta name parents dict keys) (aif it (ref self '__new__) @@ -82,44 +69,35 @@ explicitly tell it to not update etc. (class (make p))) (slot-set! class 'procedure (lambda x - (create-object class meta goops x))) - (cond - ((eq? p <pf>) - (cond - ((is-a? dict <pf>) - (slot-set! class 'h (slot-ref dict 'h)) - (slot-set! class 'n (slot-ref dict 'n)) - (slot-set! class 'size (slot-ref dict 'size))) - (else - (error "funtional class creation needs functional dicts")))) - - ((eq? p <p>) - (cond - ((is-a? dict <pf>) - (slot-set! class 'h dict)) - ((is-a? dict <p>) - (slot-set! class 'h (slot-ref dict 'h))) - (else - (slot-set! class 'h dict))))) - - (let lp ((ps parents)) - (if (pair? ps) - (let ((p (car ps))) + (create-object class meta goops x))) + (set class '__class__ meta) + (if (hashtable? dict) + (hash-for-each + (lambda (k v) (set class k v)) + dict) + (hashforeach + (lambda (k v) (set class k v)) + dict)) + (let((mro (ref class '__mro__))) + (if (pair? mro) + (let ((p (car mro))) (aif it (ref p '__init_subclass__) (apply it class #f keys) - #f) - (lp (cdr ps))))) + #f)))) class))) +(define (type- meta name parents dict keys) + (let ((class (new-class meta name parents dict keys))) + (aif it (ref meta '__init__) + (it name parents dict keys) + #f) + class)) + (define (create-class meta name parents gen-methods . keys) (let ((dict (gen-methods (get-dict meta name keys)))) - (aif it (ref (ref meta '__class__) '__call__) - (apply it name parents dict keys) - (let ((class (new-class meta name parents dict keys))) - (aif it (ref meta '__init__) - (it name parents dict keys) - #f) - class)))) + (aif it (find-in-class (ref meta '__class__) '__call__ #f) + (apply (it meta 'object) name parents dict keys) + (type- meta name parents dict keys)))) (define (create-object class meta goops x) (aif it (ref meta '__call__) @@ -616,9 +594,8 @@ explicitly tell it to not update etc. (make-p-class name parents (lambda (dict) - (let ((d (make-pf class))) - (set d 'dname dname) (... ...) - d)))) + (hash-set! d 'dname dname) (... ...))))) + name))) @@ -681,8 +658,25 @@ explicitly tell it to not update etc. #f))) #f)) +(define (pyobject? x) + (and (is-a? x <p>) + (if (is-a? x type) + #f + (if it (ref x '__class__) + (if (is-a? it type) + #f + #t))) + #f)) + +(define (pytype? x) + (and (is-a? x <p>) + (if (is-a? x type) + #t + #f) + #f)) + (define-method (py-class (o <p>)) - (ref o '__class__ 'type)) + (ref o '__class__ type)) (define (mark-fkn tag f) (set-procedure-property! f 'py-special tag) @@ -872,3 +866,21 @@ explicitly tell it to not update etc. (define-method (py-equal? x y) ((@ (guile) equal?) x y)) (define (equal? x y) (or (eq? x y) (py-equal? x y))) + +(define type 'type) +(define-python-class type () + (define __call__ + (case-lambda + ((self obj) + (if (is-a? obj type) + obj + (let ((r (ref obj '__class__))) + (if (is-a? r type) + r + (ref r '__class__))))) + ((self name bases dict . keys) + (type- meta name parents dict keys))))) + +(set type '__class__ type) + +(define-python-class object ()) |