diff options
author | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2018-04-25 20:00:41 +0200 |
---|---|---|
committer | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2018-04-25 20:00:41 +0200 |
commit | 1b2144cfb35202c05f39f279198a6ad90748be23 (patch) | |
tree | 405845e063b778e7b05077dbc66cbc318c5e0c0c | |
parent | 70e3ba150960fdbd46c69e00ef6f7437f99966c8 (diff) |
improvements
-rw-r--r-- | modules/language/python/compile.scm | 88 | ||||
-rw-r--r-- | modules/language/python/dict.scm | 26 | ||||
-rw-r--r-- | modules/language/python/for.scm | 3 | ||||
-rw-r--r-- | modules/language/python/list.scm | 8 | ||||
-rw-r--r-- | modules/language/python/module.scm | 17 | ||||
-rw-r--r-- | modules/language/python/module/enum.py | 31 | ||||
-rw-r--r-- | modules/language/python/module/python.scm | 12 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 299 |
8 files changed, 280 insertions, 204 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 93adc75..5df4f3c 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -68,32 +68,6 @@ (fluid-ref (@@ (system base message) %dont-warn-list))))) (lambda x (values)))) -(define *prefixes* (make-fluid '())) -(define (add-prefix id) - (catch #t - (lambda () - (if (fluid-ref (@@ (system base compile) %in-compile)) - (fluid-set! *prefixes* (cons id (fluid-ref *prefixes*))) - (begin - (when (not (module-defined? (current-module) '__prefixes__)) - (module-define! (current-module) - '__prefixes__ (make-fluid '()))) - - (let ((p (module-ref (current-module) '__prefixes__))) - (fluid-set! p (cons id (fluid-ref p))))))) - (lambda x (values)))) - -(define (is-prefix? id) - (catch #t - (lambda () - (if (fluid-ref (@@ (system base compile) %in-compile)) - (member id (fluid-ref *prefixes*)) - (if (not (module-defined? (current-module) '__prefixes__)) - #f - (let ((p (module-ref (current-module) '__prefixes__))) - (member id (fluid-ref p)))))) - (lambda x #f))) - (define-syntax call (syntax-rules () ((_ (f) . l) (f . l)))) @@ -317,9 +291,9 @@ (mkfast ;; General ((__init__) (O 'py-init)) - ((__getattr__) (O 'getattr)) - ((__setattr__) (O 'setattr)) - ((__delattr__) (O 'delattr)) + ((__getattr__) (O 'ref)) + ((__setattr__) (O 'set)) + ((__delattr__) (O 'del)) ((__ne__) (O 'ne)) ((__eq__) (O 'equal?)) ((__repr__) (O 'repr)) @@ -541,7 +515,7 @@ (lp (cdr l) (cons x r)))) (list (G 'cons) `(,(G 'list) ,@(reverse r)) ''())))) -(define (get-addings vs x) +(define (get-addings vs x fast?) (match x (() '()) ((x . l) @@ -558,16 +532,16 @@ (let* ((tag (exp vs x)) (xs (gensym "xs")) (fast (fastfkn tag)) - (is-fkn? (aif it (and is-fkn? fast) + (is-fkn? (aif it (and fast? is-fkn? fast) `(#:call-obj (lambda (e) (lambda ,xs (apply ,it e ,xs)))) #f))) (if is-fkn? is-fkn? - (if fast + (if (and fast? fast) `(#:fastfkn-ref ,fast ',tag) - (aif it (fast-ref tag) + (aif it (and fast? (fast-ref tag)) `(#:fast-id ,it ',tag) `(#:identifier ',tag)))))) @@ -595,7 +569,7 @@ n1 n2 n3)))) (_ (error "unhandled addings"))) - (get-addings vs l)))))) + (get-addings vs l fast?)))))) (define-syntax-rule (setwrap u) (call-with-values (lambda () u) @@ -623,25 +597,15 @@ ((#:verb x) x) ((#:test (#:power kind v addings . _) . _) (let* ((v (exp vs v)) - (v.add (if (is-prefix? v) - (let ((w (symbol->string (exp vs (car addings))))) - (cons (string-append (symbol->string v) "." w) - (cdr addings))) - (cons v addings))) - (v (car v.add)) - (addings (cdr v.add)) - (addings (get-addings vs addings)) + (fast? (not (eq? v 'super))) + (addings (get-addings vs addings fast?)) (p.a (match kind (#f (cons #f '())) ((v add) - (if (is-prefix? v) - (let ((w (symbol->string (exp vs (car add))))) - (cons (string-append (symbol->string v) "." w) - (cdr add))) - (cons (exp vs v) add))))) + (cons (exp vs v) add)))) (p (car p.a)) (pa (cdr p.a)) - (pa (get-addings vs pa))) + (pa (get-addings vs pa fast?))) (define q (lambda (x) `',x)) (if kind (if (not p) @@ -733,24 +697,14 @@ (exp vs x)) ((_ #f vf trailer . **) - (let* ((vf (exp vs vf)) - (vf.tr (if (is-prefix? vf) - (cons - (string->symbol - (string-append - (symbol->string vf) - "." - (symbol->string (exp vs (car trailer))))) - (cdr trailer)) - (cons vf trailer))) - (vf (car vf.tr)) - (trailer (cdr vf.tr))) + (let* ((vf (exp vs vf)) + (fast? (not (eq? vf 'super)))) (define (pw x) (if ** `(expt ,x ,(exp vs **)) x)) (pw - (let ((trailer (get-addings vs trailer))) + (let ((trailer (get-addings vs trailer fast?))) `(,(C 'ref-x) ,vf ,@trailer)))))) (#:identifier @@ -861,9 +815,11 @@ '(void)) ((_ (#:power #f base (l ... fin) . #f)) - (let ((add (get-addings vs l)) - (fin (get-addings vs (list fin))) - (f (exp vs base))) + (let* ((f (exp vs base)) + (fast? (not (eq? f 'super))) + (add (get-addings vs l fast?)) + (fin (get-addings vs (list fin) fast?))) + `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin)))) (#:with @@ -927,7 +883,7 @@ (() #f) (#f #f) ((#:arglist . _) - (get-addings vs (list parents)))))) + (get-addings vs (list parents) #f))))) `(set! ,class (,(C 'class-decor) ,decor (,(C 'with-class) ,class @@ -1518,7 +1474,7 @@ (x '()))) (if (fluid-ref (@@ (system base compile) %in-compile)) - (with-fluids ((*prefixes* '())) + (begin (if (fluid-ref (@@ (system base compile) %in-compile)) (set! s/d 'set!) (set! s/d (C 'define-))) diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm index f76e2ad..0e130d0 100644 --- a/modules/language/python/dict.scm +++ b/modules/language/python/dict.scm @@ -123,7 +123,7 @@ 0 o)) (define-method (py-hash (o <py-hashtable>)) - (slot-ref o 'h)) + (slot-ref o 'hash)) (define-method (len (o <hashtable>)) (hash-fold (lambda (k v s) (+ s 1)) 0 o)) @@ -543,7 +543,31 @@ (define-method (in key (o <py-hashtable>)) (py-has_key o key)) + +(define <dict> `(,<py-hashtable> . _)) +(define dict-set! (resolve-method-g pylist-set! <dict>)) +(define dict-ref (resolve-method-g pylist-ref <dict>)) +(define dict-del! (resolve-method-g pylist-delete! <dict>)) +(define dict-pop! (resolve-method-g pylist-pop! <dict>)) +(define dict-clear! (resolve-method-g py-clear <dict>)) +(define dict-get (resolve-method-g py-get <dict>)) +(define dict-len (resolve-method-g len <dict>)) +(define dict-bool (resolve-method-g bool <dict>)) + + (define-python-class dict (<py-hashtable>) + (define __getitem__ dict-ref) + (define __setitem__ dict-set!) + (define __delitem__ dict-del!) + (define pop dict-pop!) + (define clear dict-clear!) + (define get dict-get) + (define __len__ dict-len) + (define __bool__ dict-bool) + (define __format___ (lambda x #f)) + (define __setattr__ (@@ (oop pf-objects) __setattr__)) + (define __getattribute__ (@@ (oop pf-objects) __getattribute__)) + (define __init__ (letrec ((__init__ (case-lambda diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm index 7b8e57b..c618828 100644 --- a/modules/language/python/for.scm +++ b/modules/language/python/for.scm @@ -114,6 +114,9 @@ (slot-ref o 's) (slot-ref o 'i)))) +(define-method (next x) + (throw StopIteration)) + (define-method (next (l <scm-list>)) (let ((ll (slot-ref l 'l))) (if (pair? ll) diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm index ddb4be5..1a8374e 100644 --- a/modules/language/python/list.scm +++ b/modules/language/python/list.scm @@ -194,9 +194,9 @@ (define N (string-length o)) (define (f n) (if (< n 0) (+ N n) n)) - (let* ((n1 (f (if (eq? n1 None) 0 n1))) - (n2 (f (if (eq? n2 None) (slot-ref o 'n) n2))) - (n3 (f (if (eq? n3 None) 1 n3)))) + (let* ((n1 (f (if (eq? n1 None) 0 n1))) + (n2 (f (if (eq? n2 None) (string-length o) n2))) + (n3 (f (if (eq? n3 None) 1 n3)))) (list->string (to-list (pylist-slice (to-pylist o) n1 n2 n3))))) @@ -937,7 +937,7 @@ #:final #t)) -(define (py-any x) +(define (py-any . x) (for ((i : x)) () (if i (break #t)) diff --git a/modules/language/python/module.scm b/modules/language/python/module.scm index 5c5d630..6570452 100644 --- a/modules/language/python/module.scm +++ b/modules/language/python/module.scm @@ -67,11 +67,11 @@ ((self pre l nm) (match l ((name) - (set self '_path (reverse (cons name pre))) + (rawset self '_path (reverse (cons name pre))) (_cont self #f (cons name pre) #f (cons name nm) #f)) ((name . (and l (name2 . _))) - (set self '_path (reverse (cons name pre))) + (rawset self '_path (reverse (cons name pre))) (_cont self name2 (cons name pre) l (cons name nm) #t)))) @@ -122,8 +122,8 @@ (rawset self '_private #f) (if (not (rawref self '_module)) (begin - (set self '__name__ (string-join - (map symbol->string (reverse nm)) ".")) + (rawset self '__name__ (string-join + (map symbol->string (reverse nm)) ".")) (let* ((_module (in-scheme (resolve-module (reverse l)))) (public-i (and _module (module-public-interface _module)))) (if (and (not skip-error?) (not public-i)) @@ -131,8 +131,8 @@ (format #f "No module named ~a" (ref self '__name__))))) - (set self '_export (module-public-interface _module)) - (set self '_module _module) + (rawset self '_export (module-public-interface _module)) + (rawset self '_module _module) (hash-set! _modules l self)))))) (define __getattr__ @@ -177,11 +177,10 @@ (lambda (self) (let* ((h (slot-ref self 'h)) (l '()) + (m (_m self)) (add (lambda (k . u) (set! l (cons (symbol->string k) l))))) (hash-for-each add h) - (aif it (ref self '_module) - (module-for-each add it) - #f) + (module-for-each add m) (py-list l)))) diff --git a/modules/language/python/module/enum.py b/modules/language/python/module/enum.py index eefc1b5..0f623f0 100644 --- a/modules/language/python/module/enum.py +++ b/modules/language/python/module/enum.py @@ -83,7 +83,7 @@ class _EnumDict(dict): if key not in ( '_order_', '_create_pseudo_member_', '_generate_next_value_', '_missing_', - ): + ): raise ValueError('_names_ are reserved for future Enum use') if key == '_generate_next_value_': setattr(self, '_generate_next_value', value) @@ -118,7 +118,7 @@ class EnumMeta(type): def __prepare__(metacls, cls, bases): # create the namespace dict enum_dict = _EnumDict() - + # inherit previous flags and _generate_next_value_ function member_type, first_enum = metacls._get_mixins_(bases) @@ -157,14 +157,14 @@ class EnumMeta(type): # create our new Enum type enum_class = super().__new__(metacls, cls, bases, classdict) - + pk(enum_class) enum_class._member_names_ = [] # names in definition order enum_class._member_map_ = OrderedDict() # name->value map enum_class._member_type_ = member_type # save attributes from super classes so we know if we can take # the shortcut of storing members in the class dict - + base_attributes = {a for b in enum_class.mro() for a in b.__dict__} # Reverse value->name map for hashable values. @@ -261,7 +261,7 @@ class EnumMeta(type): _order_ = _order_.replace(',', ' ').split() if _order_ != enum_class._member_names_: raise TypeError('member order does not match _order_') - pk('enum class fom new',enum_class) + return enum_class def __bool__(self): @@ -364,11 +364,17 @@ class EnumMeta(type): resulting in an inconsistent Enumeration. """ + member_map = cls.__dict__.get('_member_map_', {}) + if name in member_map: raise AttributeError('Cannot reassign members.') + + pk('set',name) + super().__setattr__(name, value) + def _create_(cls, class_name, names=None, *, module=None, qualname=None, type=None, start=1): """Convenience method to create a new Enum class. @@ -516,13 +522,15 @@ class EnumMeta(type): return __new__, save_new, use_args -pk(1) + class Enum(metaclass=EnumMeta): """Generic enumeration. Derive from this class to define new enumerations. """ + pk(1) + def __new__(cls, value): # all enum instances are actually created during class construction # without calling this method; this method is called by the metaclass' @@ -543,6 +551,8 @@ class Enum(metaclass=EnumMeta): # still not found -- try _missing_ hook return cls._missing_(value) + pk(2) + def _generate_next_value_(name, start, count, last_values): for last_value in reversed(last_values): try: @@ -552,6 +562,8 @@ class Enum(metaclass=EnumMeta): else: return start + pk(3) + @classmethod def _missing_(cls, value): raise ValueError("%r is not a valid %s" % (value, cls.__name__)) @@ -571,7 +583,7 @@ class Enum(metaclass=EnumMeta): if m[0] != '_' and m not in self._member_map_ ] return (['__class__', '__doc__', '__module__'] + added_behavior) - + pk(4) def __format__(self, format_spec): # mixed-in Enums should use the mixed-in type's __format__, otherwise # we can get strange results with the Enum name showing up instead of @@ -599,7 +611,7 @@ class Enum(metaclass=EnumMeta): # to have members named `name` and `value`. This works because enumeration # members are not set directly on the enum class -- __getattr__ is # used to look them up. - + pk(5) @DynamicClassAttribute def name(self): """The name of the Enum member.""" @@ -646,7 +658,6 @@ class Enum(metaclass=EnumMeta): module_globals[name] = cls return cls -pk(2) class IntEnum(int, Enum): """Enum where members are also (and must be) ints""" @@ -763,7 +774,6 @@ class Flag(Enum): inverted = reduce(_or_, inverted_members, self.__class__(0)) return self.__class__(inverted) - class IntFlag(int, Flag): """Support for integer-based Flags""" @@ -828,7 +838,6 @@ class IntFlag(int, Flag): result = self.__class__(~self._value_) return result - def _high_bit(value): """returns index of highest bit, or -1 if value is zero or negative""" return value.bit_length() - 1 diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index ef42cc6..1a90757 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -3,9 +3,9 @@ #:use-module (ice-9 match) #:use-module (ice-9 readline) #:use-module ((oop pf-objects) #:select - (<p> <property> class-method static-method ref + (<p> <property> class-method static-method ref (set . pf-set) py-super-mac type object pylist-ref define-python-class - object-method)) + object-method py-dict)) #:use-module (language python exceptions ) #:use-module ((language python module string ) #:select ()) #:use-module ((language python module io ) #:select (open)) @@ -48,11 +48,13 @@ divmod enumerate filter getattr hasattr setattr hex isinstance issubclass iter sum id input oct ord pow super - sorted zip + sorted zip vars ClassMethod StaticMethod Funcobj)) (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) +(define vars py-dict) + (define print (case-lambda (() ((@ (guile) format) #t "~%")) @@ -112,10 +114,10 @@ r))) (define (setattr a k v) - (set a (if (string? k) (string->symbol k) k) v)) + (pf-set a (if (string? k) (string->symbol k) k) v)) (define (hasattr a b) - (let ((r (ref a (symbol->string b) miss))) + (let ((r (ref a (if (string? b) (string->symbol b) b) miss))) (not (eq? r miss)))) (define-method (issubclass x y) #f) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 4d0b697..6ee2c58 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -34,19 +34,30 @@ The datastructure is functional but the objects mutate. So one need to explicitly tell it to not update etc. |# +#; +(define (pkk . l) + (let* ((r (reverse l)) + (x (reverse (cdr r))) + (z (car r))) + (apply pk x) + z)) +(define (pkk . l) + (car (reverse l))) + + (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) (define (pk-obj o) (pk 'start-pk-obj) (let ((h (slot-ref o 'h))) (hash-for-each (lambda (k v) - (if (member k '(__name__ __qualname__)) + (if (member k '(__name__ __qualname__ __class__)) (pk k v) (pk k))) h) (pk 'finished-obj) - (let lp ((l (ref o '__mro__ '()))) + (let lp ((l (pk 'mro (ref o '__mro__ '())))) (if (pair? l) (let ((cl (car l))) (if (is-a? cl <p>) @@ -139,7 +150,6 @@ explicitly tell it to not update etc. (hash-ref h key -fail)) (hash-ref h key -fail)))) - (define-syntax-rule (find-in-class-and-parents klass key fail-) (aif parents (find-in-class klass '__mro__ #f) (let lp ((parents parents)) @@ -157,13 +167,15 @@ explicitly tell it to not update etc. (define (mk-getter-object f) (lambda (obj cls) - (if (pytype? obj) + (pkk 'obj-name (find-in-class obj '__name__ #f)) + (pkk 'cls-name (find-in-class cls '__name__ #f)) + (if (pkk 'type-obj (pytype? obj)) f - (if (pyclass? obj) - (if (pytype? cls) + (if (pkk 'class-obj (pyclass? obj)) + (if (pkk 'type-cls (pytype? cls)) (lambda x (apply f obj x)) f) - (if (pyclass? cls) + (if (pkk 'class-cls (pyclass? cls)) (lambda x (apply f obj x)) f))))) @@ -227,9 +239,28 @@ explicitly tell it to not update etc. (define (hashforeach a b) (values)) - +(define (add-default c l) + (if (pair? l) + (let ((l (let ((y (car l))) (if (eq? y c) l (cons c l))))) + (let* ((r (reverse l)) + (x (car r))) + (if x + (if (or (not type) (pytype? x)) + (if (or (not type) (eq? x type)) + l + (reverse (cons type r))) + (if (or (not object) (eq? x object)) + l + (reverse (cons object r)))) + l))) + (if object + (if (pytype? c) + (list c type) + (list c object)) + (cons c l)))) + (define (new-class0 meta name parents dict . kw) - (let* ((goops (pylist-ref dict '__goops__)) + (let* ((goops (pkk 'new-class0 name (pylist-ref dict '__goops__))) (p (kwclass->class kw meta)) (class (make-p p))) @@ -255,16 +286,37 @@ explicitly tell it to not update etc. #f) (lp (cdr mro))))) - - (set class '__mro__ (cons class (find-in-class-and-parents - class '__mro__ '()))) - (if (not (ficap class '__getattribute__ #f)) - (set class '__getattribute__ attr)) - (if (not (ficap class 'mro #f)) - (set class 'mro _mro)) + (when class + (rawset class '__class__ meta) + (rawset class '__goops__ goops) + (rawset class '__name__ (pylist-ref dict '__name__)) + (rawset class '__bases__ (pylist-ref dict '__bases__)) + + (rawset class '__mro__ + (add-default + class + (find-in-class-and-parents + class '__mro__ '()))) - (set class '__class__ meta) + (if (not (ficap class '__getattribute__ #f)) + (rawset class '__getattribute__ attr)) + + (aif it (py-get dict '__getattribute__ #f) + (rawset class '__getattribute__ it) + #f) + + (aif it (py-get dict '__getattr__) + (rawset class '__getattr__ it) + #f) + + (aif it (py-get dict '__setattr__ #f) + (rawset class '__setattr__ it) + #f) + + (aif it (py-get dict '__delattr__ #f) + (rawset class '__delattr__ it) + #f)) class)) @@ -287,6 +339,7 @@ explicitly tell it to not update etc. (obj (aif it (ficap class '__new__ #f) (apply it class x) (make-object class meta goops)))) + (aif it (ficap class '__init__ #f) (apply it obj x) #f) @@ -334,7 +387,7 @@ explicitly tell it to not update etc. (define (make-object class meta goops) (let ((obj (make-p goops))) - (set obj '__class__ class) + (rawset obj '__class__ class) obj)) ;; Make an empty pf object @@ -425,16 +478,24 @@ explicitly tell it to not update etc. (define not-implemented (cons 'not 'implemeneted)) -(define-inlinable (mrefx-py x key l) +(define (mrefx-py x key l) (let ((xx x)) - (let* ((f (aif it (mrefx xx '__getattribute__ '()) + (define (exit) (if (pair? l) (car l) #f)) + (aif class (find-in-class xx '__class__ #f) + (aif f (find-in-class-and-parents class '__getattribute__ #f) + (kif it (if (eq? f __getattribute__) + (f xx key) + (catch #t + (lambda () + (f xx (symbol->string key))) + (lambda q fail))) + it - #f))) - (if (or (not f) (eq? f not-implemented)) - (gox xx (mrefx xx key l)) - (kif it (f xx key) - it - (if (pair? l) (car l) #f)))))) + (exit)) + (kif it (__getattribute__ xx key) + it + (exit))) + #f))) (define-syntax-rule (mref x key l) (let ((xx x)) @@ -518,34 +579,23 @@ explicitly tell it to not update etc. (define *make-class* (make-fluid #f)) (define (mc?) (not (fluid-ref *make-class*))) -(define-syntax-rule (mset-py x key val) - (let* ((xx x) - (v (mref xx key (list fail)))) - (if (eq? v fail) - (let* ((g (mrefx xx '__fset__ '(#t))) - (f (if g - (if (eq? g #t) - (aif it (rawref xx '__setattr__) - (begin - (rawset xx '__fset__ it) - it) - (begin - (if (mc?) - (rawset xx '__fset__ it)) - #f)) - g) - #f))) - (if (or (eq? f not-implemented) (not f)) - (mset xx key val) - (catch #t - (lambda () (f key val)) - (lambda q (mset xx key val))))) - - (aif it (and v (find-in-class v '__class__ #f)) - (aif it (ref it '__set__) - (it val) - (mset xx key val)) - (mset xx key val))))) +(define __setattr__ + (lambda (self key val) + (kif desc (ref self key fail) + (aif it (ref desc '__set__) + (it self val) + (mset self key val)) + (mset self key val)))) + +(define (mset-py x key val) + (let* ((xx x)) + (aif class (find-in-class xx '__class__ #f) + (aif f (find-in-class-and-parents class '__setattr__ #f) + (if (eq? f __setattr__) + (f xx key val) + (f xx (symbol->string key) val)) + (__setattr__ xx key val)) + (mset xx key val)))) (define-syntax-rule (mklam (mset a ...) val) (mset a ... val)) @@ -862,8 +912,9 @@ explicitly tell it to not update etc. (cons y (lp (cdr x))) (lp (cdr x)))) '()))) - + (methods dict) + (pylist-set! dict '__goops__ goops) (pylist-set! dict '__class__ meta) (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table)) @@ -996,7 +1047,8 @@ explicitly tell it to not update etc. (make-p-class 'name doc parents (lambda (dict) - (pylist-set! dict 'dname dname) + (begin + (pylist-set! dict 'dname dname)) ... (values))))) (begin @@ -1129,36 +1181,41 @@ explicitly tell it to not update etc. (define (not-a-super) 'not-a-super) (define (py-super class obj) (define (make cl parents) + (pk 'parents cl parents) (if (not cl) #f (let ((c (make-p <py>)) (o (make-p <py>))) - (set c '__class__ type) - (set c '__mro__ (cons* c parents)) - (set c '__getattribute__ - (lambda (self key) - (kif it (ficap c key fail) - (aif dt (ref it '__get__) - (dt obj cl) - it) - fail))) - (set c '__name__ "**super**") - (set o '__class__ c) + (rawset c '__class__ type) + (rawset c '__mro__ (cons* c parents)) + (rawset c '__getattribute__ + (lambda (self key) + (set! key (if (string? key) (string->symbol key) key)) + (pk 'key key) + (pk key (kif it (pk 'it (ficap c key fail)) + (aif dt (pk '__get__ (ref it '__get__)) + (dt obj cl) + it) + fail)))) + (rawset c '__name__ "**super**") + (rawset o '__class__ c) o))) - + + (pk 'super class (ref obj '__name__)) + (call-with-values (lambda () - (let lp ((l (ref (if (or (pytype? obj) (pyclass? obj)) - obj - (ref obj '__class__)) - '__mro__ '()))) - (if (pair? l) - (if (eq? class (car l)) - (let ((r (cdr l))) - (if (pair? r) - (values (car r) r) - (values #f #f))) - (lp (cdr l))) + (let ((ll (pk 'l class (ref (ref obj '__class__) '__mro__ '())))) + (if (pair? ll) + (let lp ((l ll)) + (if (pair? l) + (if (eq? class (car l)) + (let ((r (cdr l))) + (if (pair? r) + (values (car r) r) + (values #f #f))) + (lp (cdr l))) + (values (car ll) ll))) (values #f #f)))) make)) @@ -1201,9 +1258,13 @@ explicitly tell it to not update etc. - +(define-method (py-init . l) + (values)) + (define-method (py-init (o <p>) . l) - (apply (ref o '__init__) l)) + (aif it (ref o '__init__) + (apply it l) + (next-method))) (define mk-tree (case-lambda @@ -1252,7 +1313,7 @@ explicitly tell it to not update etc. (define (class-to-tree cl) (cons cl (map class-to-tree - (find-in-class cl '__bases__ #f)))) + (ref cl '__bases__ '())))) (define (find-tree o tree) (if tree @@ -1317,6 +1378,7 @@ explicitly tell it to not update etc. (hash-fold (lambda (k v s) (cons k s)) '() h)) '())) + (define __getattribute__ (case-lambda ((self key) @@ -1325,30 +1387,38 @@ explicitly tell it to not update etc. (find-in-class self '__mro__ fail) fail)) - (aif class (find-in-class self '__class__ #f) - (kif it1 (find-in-class-and-parents class key fail) - (aif dd1 (rawref it1 '__get__) - (if (rawref it1 '__set__) - (dd1 self class) + (aif class (pkk 'class (find-in-class self '__class__ #f)) + (kif it1 (pkk 'c (find-in-class-and-parents class key fail)) + (aif dd1 (pkk 'get (rawref it1 '__get__)) + (if (pkk 'set (rawref it1 '__set__)) + (pkk 'desc key (dd1 self class)) (kif it2 (find-in-class-and-parents self key fail) - it2 - (dd1 self class))) - (kif it2 (find-in-class-and-parents self key fail) - it2 - it1)) - (kif it2 (find-in-class-and-parents self key fail) - it2 - (aif it (find-in-class-and-parents class '__getattr__ #f) - (kif it1 (it self key) + (pkk 'object key it2) + (pkk 'gox key (dd1 self class)))) + (kif it2 (pkk 'o (find-in-class-and-parents self key fail)) + (pkk 'object key it2) + (pkk 'class key it1))) + (kif it2 (pkk 'o2 (find-in-class-and-parents self key fail)) + (pkk 'object key it2) + (aif it (pkk 'getattr + (find-in-class-and-parents class '__getattr__ #f)) + (kif it1 (catch #t + (lambda () (it self (symbol->string key))) + (lambda x fail)) (aif dd1 (rawref it1 '__get__) - (dd1 self class) - it1) - (-fail class)) - (-fail class)))) - fail)))) + (pkk 'getattr-gox key (dd1 self class)) + (pkk 'getattr key it1)) + (pkk 'fail1 (-fail class))) + (pkk 'fail2 (-fail class))))) + (pkk 'classfail fail))))) (define attr __getattribute__) +(define (*str* self) + (scmstr (ref self '__name__))) + +(define *setattr* __setattr__) + (set! type (make-python-class type () (define __new__ new-class0) @@ -1356,19 +1426,29 @@ explicitly tell it to not update etc. (define ___zub_classes__ (make-weak-key-hash-table)) (define __subclasses__ subclasses) (define __call__ type-call) + (define __str__ *str*) + (define __getattribute__ attr) + (define __setattr__ (object-method *setattr*)) + (define __format__ (lambda (self x) (*str* self))) + (define __reduce_ex__ (lambda x (error "not implemented"))) (define mro (lambda (self) (ref self '__mro__))))) (set type '__class__ type) (define _mro (object-method (lambda (self) (ref self '__mro__)))) +(define (scmstr s) (if (symbol? s) (symbol->string s) s)) + (set! object (make-python-class object () (define __init__ (lambda x (values))) (define __subclasses__ subclasses) (define __getattribute__ attr) - (define __weakref__ (lambda (self) self)) - (define mro _mro))) + (define __setattr__ (object-method *setattr*)) + (define __str__ *str*) + (define __format__ (lambda (self x) (*str* self))) + (define __reduce_ex__ (lambda x (error "not implemented"))) + (define __weakref__ (lambda (self) self)))) (name-object type) @@ -1379,13 +1459,16 @@ explicitly tell it to not update etc. it (next-method))) +(define-python-class NoneObj () + (define __new__ + (lambda x 'None))) +(define-method (py-dict x) + (if (eq? x 'None) + (py-dict NoneObj) + (make-hash-table))) + (define-method (py-dict (o <p>)) (aif it (ref o '__dict__) it (slot-ref o 'h))) - -(define-python-class NoneObj () - (define __new__ - (lambda x 'None))) - |