From 3d529f7540ca954131802a832be6811f2815ed0e Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Sun, 6 May 2018 10:36:08 +0200 Subject: enum compiles and loads without errors --- modules/language/python/compile.scm | 4 +- modules/language/python/dict.scm | 117 +++++-- modules/language/python/exceptions.scm | 6 +- modules/language/python/hash.scm | 12 +- modules/language/python/list.scm | 9 - modules/language/python/module.scm | 16 +- modules/language/python/module/collections.scm | 113 ++++--- modules/language/python/module/collections/abc.scm | 19 +- modules/language/python/module/enum.py | 47 +-- modules/language/python/module/python.scm | 8 +- modules/language/python/string.scm | 4 +- modules/oop/pf-objects.scm | 370 ++++++++++++--------- 12 files changed, 442 insertions(+), 283 deletions(-) diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 5df4f3c..00443a9 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -1118,7 +1118,7 @@ (let* ((decor (let ((r (fluid-ref decorations))) (fluid-set! decorations '()) r)) - (arg_ (get-args_ vs args)) + (arg_ (get-args_ vs args)) (arg= (get-args= vs args)) (dd= (map cadr arg=)) (c? (fluid-ref is-class?)) @@ -1131,7 +1131,7 @@ (dd** (map cadr **f)) (aa `(,@arg_ ,@*f ,@arg= ,@**f)) (ab (gensym "ab")) - (vs (union dd** (union dd* (union dd= (union args vs))))) + (vs (union dd** (union dd* (union dd= (union arg_ vs))))) (ns (scope code vs)) (df (defs code '())) (ex (gensym "ex")) diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm index 0e130d0..18420dd 100644 --- a/modules/language/python/dict.scm +++ b/modules/language/python/dict.scm @@ -191,7 +191,7 @@ (let ((ret (py-hash-ref t key miss))) (if (eq? ret miss) (begin - (py-hash-set! t key val) + (py-hash-set! t key val) (slot-set! o 'n (+ n 1)) (slot-set! o 'hash (logxor (xy (py-hash key) (py-hash val)) h))) (begin @@ -275,7 +275,7 @@ (let ((elseval (match l (() None) ((v) v)))) - (let ((ret (ref o k miss))) + (let ((ret (py-hash-ref o k miss))) (if (eq? ret miss) elseval ret)))) @@ -284,7 +284,7 @@ (let ((elseval (match l (() None) ((v) v)))) - (let ((ret (ref (slot-ref o 't) k miss))) + (let ((ret (py-hash-ref (slot-ref o 't) k miss))) (if (eq? ret miss) elseval ret))))) @@ -545,29 +545,40 @@ (define `(, . _)) -(define dict-set! (resolve-method-g pylist-set! )) -(define dict-ref (resolve-method-g pylist-ref )) -(define dict-del! (resolve-method-g pylist-delete! )) -(define dict-pop! (resolve-method-g pylist-pop! )) -(define dict-clear! (resolve-method-g py-clear )) -(define dict-get (resolve-method-g py-get )) -(define dict-len (resolve-method-g len )) -(define dict-bool (resolve-method-g bool )) - - -(define-python-class dict () +(define `(, ,)) +(define (resolve a b) (object-method (resolve-method-g a b))) +(define dict-set! (resolve pylist-set! )) +(define dict-ref (resolve pylist-ref )) +(define dict-del! (resolve pylist-delete! )) +(define dict-pop! (resolve pylist-pop! )) +(define dict-clear! (resolve py-clear )) +(define dict-get (resolve py-get )) +(define dict-len (resolve len )) +(define dict-bool (resolve bool )) +(define dict-in (resolve in )) +(define dict-items (resolve py-items )) + +(define-python-class dict ( ) (define __getitem__ dict-ref) - (define __setitem__ dict-set!) + (define __setitem__ + (lambda (self key val) + (dict-set! self key val))) (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 items dict-items) + (define __iter__ (lambda (self) + (wrap-in (slot-ref self 't)))) + (define __contains__ + (lambda (self x) (dict-in x self))) (define __format___ (lambda x #f)) (define __setattr__ (@@ (oop pf-objects) __setattr__)) (define __getattribute__ (@@ (oop pf-objects) __getattribute__)) - + + (define __init__ (letrec ((__init__ (case-lambda @@ -591,7 +602,71 @@ __init__))) -(define-python-class weak-key-dict () +(define (norm k) + (if (symbol? k) + (symbol->string k) + k)) + +(define fail (list 'fail)) + +(define-python-class dictNs () + (define __getitem__ + (lambda (self k) + (pylist-ref (ref self '_dict) (norm k)))) + + (define __setitem__ + (lambda (self k v) + (pylist-set! (ref self '_dict) (norm k) v))) + + (define __iter__ + (lambda (self) + (wrap-in (ref self '_dict)))) + + (define pop + (lambda (self k . l) + (apply pylist-pop! (ref self '_dict) (norm k) l))) + + (define clear + (lambda (self) + (py-clear (ref self '_dict)))) + + (define get + (lambda (self key . l) + (apply py-get (ref self '_dict) (norm key) l))) + + (define __len__ + (lambda (self) + (len (ref self '_dict)))) + + (define __bool__ + (lambda (self) + (bool (ref self '_dict)))) + + (define __contains__ + (lambda (self x) + (in (norm x) (ref self '_dict)))) + + (define items + (lambda (self) + (py-items (ref self '_dict)))) + + (define __repr__ + (lambda (self) + (format #f "Ns:~a" (ref (ref self '_dict) '__name__)))) + + (define __getattr__ + (lambda (self key) + (let ((r (ref (ref self '_dict) key fail))) + (if (eq? r fail) + (raise (AttributeError key)) + r)))) + + (define __init__ + (lambda (self d) (set self '_dict d)))) + +(set! (@@ (oop pf-objects) dictNs) dictNs) + +(define-python-class weak-key-dict ( ) (define __init__ (letrec ((__init__ (case-lambda @@ -610,7 +685,7 @@ (slot-ref x 't))))))) __init__))) -(define-python-class weak-value-dict () +(define-python-class weak-value-dict ( ) (define __init__ (letrec ((__init__ (case-lambda @@ -647,6 +722,10 @@ (pylist-sort! l) l)) - +(set! (@@ (oop pf-objects) hash-for-each*) + (lambda (f dict) + (for ((k v : dict)) () + (f k v)))) + (define-method (py-class (o )) dict) (define-method (py-class (o )) dict) diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm index 9d51116..0e16e4b 100644 --- a/modules/language/python/exceptions.scm +++ b/modules/language/python/exceptions.scm @@ -22,11 +22,11 @@ (define __repr__ (lambda (self) - (aif it (ref self 'value #f) + (aif it (rawref self 'value #f) (format #f "~a:~a" - (ref self '__name__) it) + (rawref self '__name__) it) (format #f "~a" - (ref self '__name__)))))) + (rawref self '__name__)))))) (define-syntax define-er (syntax-rules () diff --git a/modules/language/python/hash.scm b/modules/language/python/hash.scm index 168cd44..423abb3 100644 --- a/modules/language/python/hash.scm +++ b/modules/language/python/hash.scm @@ -42,7 +42,11 @@ s)))) (define-method (py-hash (x

)) - (aif it (ref x '__hash__) - (pk 'hash (it)) - (next-method))) - + (define (next) + (catch #t + (lambda () (next-method)) + (lambda x (hash x N)))) + + (aif it (ref-class x '__hash__ #f) + (it) + (next))) diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm index 1a8374e..91b66b4 100644 --- a/modules/language/python/list.scm +++ b/modules/language/python/list.scm @@ -144,11 +144,6 @@ (define-method (pylist-ref (o ) n) (vector-ref o n)) -(define-method (pylist-ref (o

) n) - (aif it (ref o '__getitem__) - (it n) - (next-method))) - ;;; SET (define-method (pylist-set! (o ) nin val) (define N (slot-ref o 'n)) @@ -164,10 +159,6 @@ (define-method (pylist-set! (o ) n val) (vector-set! o n val)) -(define-method (pylist-set! (o

) n val) - (aif it (ref o '__setitem__) - (it n val) - (next-method))) ;;SLICE (define-method (pylist-slice (o

) n1 n2 n3) diff --git a/modules/language/python/module.scm b/modules/language/python/module.scm index 6570452..101f62e 100644 --- a/modules/language/python/module.scm +++ b/modules/language/python/module.scm @@ -139,15 +139,13 @@ (lambda (self k) (define (fail) (raise (AttributeError "getattr in Module"))) - (if (rawref self '_module) - (let ((k (_k k)) - (m (_m self))) - (let ((x (module-ref m k e))) - (if (eq? e x) - (fail) - x))) - (fail)))) - + (let ((k (_k k)) + (m (_m self))) + (let ((x (module-ref m k e))) + (if (eq? e x) + (fail) + x))))) + (define __setattr__ (lambda (self k v) (let ((k (_k k)) diff --git a/modules/language/python/module/collections.scm b/modules/language/python/module/collections.scm index 1a158c9..04f7ab6 100644 --- a/modules/language/python/module/collections.scm +++ b/modules/language/python/module/collections.scm @@ -94,20 +94,19 @@ (define-python-class OrderedDict (dict) (define __init__ (lam (self (* args) (** kwds)) + ((ref dict '__init__) self) + (if (> (len args) 1) (raise TypeError (format #f "expected at most 1 arguments, got ~a" (len args)))) - (try - (lambda () (ref self '__root)) - (#:except AttributeError => - (lambda x - (let* ((l (link))) - (set self '__root l) - (set-next! l l) - (set-prev! l l))))) + (if (not (ref self '__root)) + (let* ((l (link))) + (set self '__root l) + (set-next! l l) + (set-prev! l l))) (set self '__map (dict)) (py-apply py-update self (* args) (** kwds)))) @@ -127,7 +126,7 @@ (set-key! link key) (set-next! last link) (set-prev! root link) - (dict_setitem self key value))))) + (dict-set! self key value))))) (define __delitem__ (lam (self key (= dict_delitem dict-del!)) @@ -145,7 +144,7 @@ (lambda (yield) (let ((root (ref self '__root))) (let lp ((curr (get-next root))) - (if ((not (eq? curr root))) + (if (not (eq? curr root)) (let ((key (get-key curr))) (yield key (pylist-ref self key)) (lp (get-next curr))))))))))) @@ -209,11 +208,16 @@ (define __update update) (define keys - (lambda (self) _OrderedDictKeysView(self))) + (lambda (self) + (_OrderedDictKeysView self))) + (define items - (lambda (self) _OrderedDictItemsView(self))) + (lambda (self) + (_OrderedDictItemsView self))) + (define values - (lambda (self) _OrderedDictValuesView(self))) + (lambda (self) + (_OrderedDictValuesView self))) (define __ne__ (ref MutableMapping '__ne__)) @@ -645,51 +649,54 @@ (make-p-class (string->symbol typename) '(()) (lambda (dict) - (pylist-set! dict '__init__ - (eval (v `(lam - (self - ,@(map (lambda (key) `(= ,key #f)) - field_names)) + (pylist-set! dict '__init__ + (object-method + (eval (v `(lam + (self + ,@(map (lambda (key) `(= ,key #f)) + field_names)) - ,@(map (lambda (key) `(set self ',key ,key)) - field_names))) - mod)) + ,@(map (lambda (key) `(set self ',key ,key)) + field_names))) + mod))) - (pylist-set! dict '__getitem__ - (lam (self i) - (if (number? i) - (ref self (list-ref field_names i)) - (ref self (scm-sym i))))) + (pylist-set! dict '__getitem__ + (object-method + (lambda (self i) + (if (number? i) + (ref self (list-ref field_names i)) + (ref self (scm-sym i)))))) - (pylist-set! dict '__setitem__ - (lam (self i val) - (if (number? i) - (set self (list-ref field_names i) val) - (set self (scm-sym i) val)))) - - (pylist-set! dict '__repr__ - (lam (self) - (let ((l (map (lambda (x) - (format #f "~a=~a" - x - (ref self x))) - field_names))) - - (format #f "~a(~a~{,~a~})" - typename - (car l) - (cdr l))))) + (pylist-set! dict '__setitem__ + (object-method + (lambda (self i val) + (if (number? i) + (set self (list-ref field_names i) val) + (set self (scm-sym i) val))))) + + (pylist-set! dict '__repr__ + (object-method + (lambda (self . l) + (let ((l (map (lambda (x) + (format #f "~a=~a" + x + (ref self x))) + field_names))) + (format #f "~a(~a~{,~a~})" + typename + (car l) + (cdr l)))))) - (if (eq? module None) - (set! module (module-name (current-module))) - (if (string? (scm-str module)) - (set! module - (+ '(language python module) - (map scm-sym - (string-split module #\.)))))) - - (if verbose (pretty-print verbose)))))) + (if (eq? module None) + (set! module (module-name (current-module))) + (if (string? (scm-str module)) + (set! module + (+ '(language python module) + (map scm-sym + (string-split module #\.)))))) + + (if verbose (pretty-print verbose)))))) (define UserDict dict) (define UserString pystring) diff --git a/modules/language/python/module/collections/abc.scm b/modules/language/python/module/collections/abc.scm index 4bd242d..4d442d3 100644 --- a/modules/language/python/module/collections/abc.scm +++ b/modules/language/python/module/collections/abc.scm @@ -516,7 +516,10 @@ (define __iter__ (lambda (self) - ((ref (ref self '_mapping) 'items))))) + ((make-generator () + (lambda (yield) + (for ((k v : (ref self '_mapping))) () + (yield (list k v))))))))) (define-python-class KeysView (MappingView Set) ;; Mixins @@ -524,10 +527,13 @@ (lambda (self k) (let ((m (ref self '_mapping))) (in k m)))) - + (define __iter__ (lambda (self) - ((ref (ref self '_mapping) 'keys))))) + ((make-generator () + (lambda (yield) + (for ((k v : (ref self '_mapping))) () + (yield k)))))))) (define-python-class ValuesView (MappingView) ;; Mixins @@ -541,6 +547,7 @@ (define __iter__ (lambda (self) - ((ref (ref self '_mapping) 'values))))) - - + ((make-generator () + (lambda (yield) + (for ((k v : (ref self '_mapping))) () + (yield v)))))))) diff --git a/modules/language/python/module/enum.py b/modules/language/python/module/enum.py index 0f623f0..723fab7 100644 --- a/modules/language/python/module/enum.py +++ b/modules/language/python/module/enum.py @@ -50,14 +50,12 @@ def _make_class_unpicklable(cls): _auto_null = object() - class auto: """ Instances are replaced with an appropriate value in Enum class suites. """ value = _auto_null - class _EnumDict(dict): """Track enum member order and ensure member names are not reused. @@ -90,10 +88,10 @@ class _EnumDict(dict): elif _is_dunder(key): if key == '__order__': key = '_order_' - elif key in self._member_names: + elif (key in self._member_names): # descriptor overwriting an enum? raise TypeError('Attempted to reuse key: %r' % key) - elif not _is_descriptor(value): + elif (not _is_descriptor(value)): if key in self: # enum overwriting a descriptor? raise TypeError('%r already defined as: %r' % (key, self[key])) @@ -105,13 +103,12 @@ class _EnumDict(dict): self._last_values.append(value) super().__setitem__(key, value) - # Dummy value for Enum as EnumMeta explicitly checks for it, but of course # until EnumMeta finishes running the first time the Enum class doesn't exist. # This is also why there are checks in EnumMeta like `if Enum is not None` Enum = None - +pk('EnumMeta') class EnumMeta(type): """Metaclass for Enum""" @classmethod @@ -132,13 +129,15 @@ class EnumMeta(type): # cannot be mixed with other types (int, float, etc.) if it has an # inherited __new__ unless a new __new__ is defined (or the resulting # class will fail). + member_type, first_enum = metacls._get_mixins_(bases) - __new__, save_new, use_args = metacls._find_new_(classdict, member_type, - first_enum) + new, save_new, use_args = metacls._find_new_(classdict, member_type, + first_enum) # save enum items into separate mapping so they don't get baked into # the new class enum_members = {k: classdict[k] for k in classdict._member_names} + for name in classdict._member_names: del classdict[name] @@ -150,21 +149,19 @@ class EnumMeta(type): if invalid_names: raise ValueError('Invalid enum member name: {0}'.format( ','.join(invalid_names))) - + # create a default docstring if one has not been provided if '__doc__' not in classdict: classdict['__doc__'] = 'An enumeration.' # 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. @@ -197,14 +194,16 @@ class EnumMeta(type): args = (value, ) else: args = value + if member_type is tuple: # special case for tuple enums args = (args, ) # wrap it one more time + if not use_args: - enum_member = __new__(enum_class) + enum_member = new(enum_class) if not hasattr(enum_member, '_value_'): enum_member._value_ = value else: - enum_member = __new__(enum_class, *args) + enum_member = new(enum_class, *args) if not hasattr(enum_member, '_value_'): if member_type is object: enum_member._value_ = value @@ -214,6 +213,7 @@ class EnumMeta(type): enum_member._name_ = member_name enum_member.__objclass__ = enum_class enum_member.__init__(*args) + # If another member with the same value was already defined, the # new member becomes an alias to the existing one. for name, canonical_member in enum_class._member_map_.items(): @@ -223,11 +223,13 @@ class EnumMeta(type): else: # Aliases don't appear in member names (only in __members__). enum_class._member_names_.append(member_name) + # performance boost for any member that would not shadow # a DynamicClassAttribute if member_name not in base_attributes: setattr(enum_class, member_name, enum_member) # now add to _member_map_ + enum_class._member_map_[member_name] = enum_member try: # This may fail if value is not hashable. We can't add the value @@ -370,8 +372,6 @@ class EnumMeta(type): if name in member_map: raise AttributeError('Cannot reassign members.') - pk('set',name) - super().__setattr__(name, value) @@ -522,6 +522,7 @@ class EnumMeta(type): return __new__, save_new, use_args +pk('enum') class Enum(metaclass=EnumMeta): """Generic enumeration. @@ -529,7 +530,6 @@ class Enum(metaclass=EnumMeta): Derive from this class to define new enumerations. """ - pk(1) def __new__(cls, value): # all enum instances are actually created during class construction @@ -551,8 +551,6 @@ 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: @@ -562,8 +560,6 @@ 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__)) @@ -583,7 +579,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 @@ -611,7 +607,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.""" @@ -658,6 +654,7 @@ class Enum(metaclass=EnumMeta): module_globals[name] = cls return cls +pk('intenum') class IntEnum(int, Enum): """Enum where members are also (and must be) ints""" @@ -666,6 +663,7 @@ class IntEnum(int, Enum): def _reduce_ex_by_name(self, proto): return self.name +pk('flag') class Flag(Enum): """Support for flags""" @@ -773,7 +771,8 @@ class Flag(Enum): ] inverted = reduce(_or_, inverted_members, self.__class__(0)) return self.__class__(inverted) - + +pk('intflag') class IntFlag(int, Flag): """Support for integer-based Flags""" @@ -837,6 +836,8 @@ class IntFlag(int, Flag): def __invert__(self): result = self.__class__(~self._value_) return result + +pk('rest') def _high_bit(value): """returns index of highest bit, or -1 if value is zero or negative""" diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index 1a90757..7b01c93 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -324,7 +324,13 @@ (define-python-class StaticMethod ()) (define-python-class Funcobj ()) +(define-method (py-mod (s ) l) + (let* ((s (py-replace s "%s" "~a")) + (s (py-replace s "%r" "~a")) + (l (for ((x : l)) ((r '())) + (cons x r) + #:final (reverse r)))) + (apply (@ (guile) format) #f s l))) - diff --git a/modules/language/python/string.scm b/modules/language/python/string.scm index f94580c..ff90ef1 100644 --- a/modules/language/python/string.scm +++ b/modules/language/python/string.scm @@ -56,7 +56,9 @@ (define-method (f (o ) . l) (apply f (slot-ref o 'str) l)))) (define-py0 (pylist-ref s i) - (list->string (list (string-ref s i)))) + (list->string (list (string-ref s (if (< i 0) + (+ (len s) i) + i))))) (define-py0 (bool s) (not (= (len s) 0))) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 6ee2c58..361e6ee 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -18,6 +18,7 @@ *class* *self* pyobject? pytype? type object pylist-set! pylist-ref tr resolve-method-g rawref rawset py-dict + ref-class )) #| @@ -34,6 +35,9 @@ The datastructure is functional but the objects mutate. So one need to explicitly tell it to not update etc. |# +;; this is mutated by the dict class +(define dictNs '(dictNs)) + #; (define (pkk . l) (let* ((r (reverse l)) @@ -41,6 +45,8 @@ explicitly tell it to not update etc. (z (car r))) (apply pk x) z)) + + (define (pkk . l) (car (reverse l))) @@ -115,6 +121,16 @@ explicitly tell it to not update etc. (name-object ) (name-object ) +(define-method (pylist-set! (o

) key val) + (aif it (ref o '__setitem__) + (it key val) + (next-method))) + +(define-method (pylist-ref (o

) key) + (aif it (ref o '__getitem__) + (it key) + (next-method))) + (define-method (ref (o ) key . l) (aif it (procedure-property o key) it @@ -147,12 +163,30 @@ explicitly tell it to not update etc. (aif dict (hash-ref h '__dict__) (kif it (py-get dict key fail) it - (hash-ref h key -fail)) + (kif it (py-get dict (symbol->string key) fail) + it + (hash-ref h key -fail))) (hash-ref h key -fail)))) +(define-method (find-in-class x key fail) fail) + +(define-method (find-in-class-raw (klass ) key fail) + (let ((r (vhash-assoc key (slot-ref klass 'h)))) + (if r + (cdr r) + fail))) + +(define-method (find-in-class-raw (klass

) key -fail) + (let ((h (slot-ref klass 'h))) + (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)) + (aif parents (let ((x (find-in-class-raw klass '__mro__ #f))) + (if (null? x) + #f + x)) + (let lp ((parents parents)) (if (pair? parents) (kif r (find-in-class (car parents) key fail) r @@ -162,20 +196,35 @@ explicitly tell it to not update etc. r fail-))) -(define-inlinable - (ficap klass key fail) (find-in-class-and-parents klass key fail)) +(define-syntax-rule (find-in-class-and-parents-raw klass key fail-) + (aif parents (find-in-class-raw klass '__mro__ #f) + (let lp ((parents parents)) + (if (pair? parents) + (kif r (find-in-class-raw (car parents) key fail) + r + (lp (cdr parents))) + fail-)) + (kif r (find-in-class-raw klass key fail) + r + fail-))) + +(define-inlinable (ficap klass key fail) + (find-in-class-and-parents klass key fail)) + +(define-inlinable (ficap-raw klass key fail) + (find-in-class-and-parents-raw klass key fail)) (define (mk-getter-object f) (lambda (obj cls) - (pkk 'obj-name (find-in-class obj '__name__ #f)) - (pkk 'cls-name (find-in-class cls '__name__ #f)) - (if (pkk 'type-obj (pytype? obj)) + (find-in-class obj '__name__ #f) + (find-in-class cls '__name__ #f) + (if (pytype? obj) f - (if (pkk 'class-obj (pyclass? obj)) - (if (pkk 'type-cls (pytype? cls)) + (if (pyclass? obj) + (if (pytype? cls) (lambda x (apply f obj x)) f) - (if (pkk 'class-cls (pyclass? cls)) + (if (pyclass? cls) (lambda x (apply f obj x)) f))))) @@ -225,7 +274,7 @@ explicitly tell it to not update etc. (if (pair? ms) (let* ((m (car ms)) (p (method-specializers m)) - (f (method-generic-function m))) + (f (method-procedure m))) (aif it (mmatch p pattern) (cons (cons it f) (lp (cdr ms))) (lp (cdr ms)))) @@ -258,66 +307,47 @@ explicitly tell it to not update etc. (list c type) (list c object)) (cons c l)))) - + +(define hash-for-each* hash-for-each) + (define (new-class0 meta name parents dict . kw) - (let* ((goops (pkk 'new-class0 name (pylist-ref dict '__goops__))) + (let* ((goops (pylist-ref dict '__goops__)) (p (kwclass->class kw meta)) (class (make-p p))) (slot-set! class 'procedure (lambda x (create-object class x))) - - (if (hash-table? dict) - (hash-for-each - (lambda (k v) k (set class k v)) - dict) - (begin (set class '__dict__ dict))) - - (let lp ((mro (find-in-class class '__mro__ #f))) - (if (pair? mro) - (let ((p (car mro))) - (aif it (find-in-class p '__zub_classes__ #f) - (hash-set! it class #t) - #f) - - (aif it (find-in-class p '__init_subclass__ #f) - (apply it class p #f kw) - #f) - - (lp (cdr 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__ '()))) + (let lp ((mro (pylist-ref dict '__mro__))) + (if (pair? mro) + (let ((p (car mro))) + (aif it (find-in-class p '__zub_classes__ #f) + (hash-set! it class #t) + #f) + + (aif it (find-in-class p '__init_subclass__ #f) + (apply it class p #f kw) + #f) + + (lp (cdr mro))))) - (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) + (hash-for-each* + (lambda (k v) + (let ((k (if (string? k) (string->symbol k) k))) + (rawset class k v))) + dict) - (aif it (py-get dict '__setattr__ #f) - (rawset class '__setattr__ it) - #f) - - (aif it (py-get dict '__delattr__ #f) - (rawset class '__delattr__ it) - #f)) - + (rawset class '__goops__ goops) + + (let ((mro (add-default class (pylist-ref dict '__mro__)))) + (rawset class '__mro__ mro)) + + (if (not (ficap-raw class '__getattribute__ #f)) + (rawset class '__getattribute__ attr))) + class)) (define (new-class meta name parents dict kw) @@ -330,11 +360,12 @@ explicitly tell it to not update etc. (aif it (and meta (find-in-class-and-parents meta '__init__ #f)) (it class name parents dict keys) #f) + class)) (define (the-create-object class x) - (let* ((meta (and class (find-in-class class '__class__ #f))) + (let* ((meta (and class (find-in-class-raw class '__class__ #f))) (goops (find-in-class class '__goops__ #f)) (obj (aif it (ficap class '__new__ #f) (apply it class x) @@ -355,7 +386,7 @@ explicitly tell it to not update etc. (define (create-object class x) (if (pytype? class) (apply type-call class x) - (let ((meta (and class (find-in-class class '__class__ #f)))) + (let ((meta (and class (find-in-class-raw class '__class__ #f)))) (with-fluids ((*make-class* #t)) (aif it (ficap meta '__call__ #f) (apply it class x) @@ -366,7 +397,7 @@ explicitly tell it to not update etc. (if (pytype? class) (apply (case-lambda ((meta obj) - (and obj (find-in-class obj '__class__ 'None))) + (and obj (find-in-class-raw obj '__class__ 'None))) ((meta name bases dict . keys) (type- meta name bases dict keys))) class l) @@ -374,13 +405,13 @@ explicitly tell it to not update etc. (define (get-dict self name parents) (aif it (and self (ficap self '__prepare__ #f)) - (it self name parents) + (dictNs (it self name parents)) (make-hash-table))) (define (create-class meta name parents gen-methods keys) (let ((dict (gen-methods (get-dict meta name parents)))) - (aif it (and meta (find-in-class meta '__class__ #f)) - (aif it (find-in-class it '__call__ #f) + (aif it (and meta (find-in-class-raw meta '__class__ #f)) + (aif it (ficap-raw it '__call__ #f) (apply it meta name parents dict keys) (type- meta name parents dict keys)) (type- meta name parents dict keys)))) @@ -468,7 +499,7 @@ explicitly tell it to not update etc. (fluid-set! *location* klass) (kif it (find-in-class-and-parents klass key fail) it - (aif klass (and klass (find-in-class klass '__class__ #f)) + (aif klass (and klass (find-in-class-raw klass '__class__ #f)) (begin (fluid-set! *location* klass) (kif it (find-in-class-and-parents klass key fail) @@ -481,8 +512,8 @@ explicitly tell it to not update etc. (define (mrefx-py x key l) (let ((xx x)) (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) + (aif class (find-in-class-raw xx '__class__ #f) + (aif f (ficap-raw class '__getattribute__ #f) (kif it (if (eq? f __getattribute__) (f xx key) (catch #t @@ -580,17 +611,21 @@ explicitly tell it to not update etc. (define (mc?) (not (fluid-ref *make-class*))) (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)))) + (lambda (self key1 val) + (define key (if (string? key1) (string->symbol key1) key1)) + (let ((h (aif dict (rawref self '__dict__) + dict + (slot-ref self 'h)))) + (kif desc (py-get h key fail) + (aif it (rawref desc '__set__ #f) + (it self val) + (pylist-set! h key val)) + (pylist-set! h 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) + (aif class (find-in-class-raw xx '__class__ #f) + (aif f (find-in-class-and-parents-raw class '__setattr__ #f) (if (eq? f __setattr__) (f xx key val) (f xx (symbol->string key) val)) @@ -866,14 +901,14 @@ explicitly tell it to not update etc. (if (null? cparents) type (let* ((p (car cparents)) - (m (ref p '__class__)) + (m (rawref p '__class__)) (mro (reverse (ref m '__mro__ '())))) (let lp ((l (cdr cparents)) (max mro) (min mro)) (if (pair? l) (let* ((p (car l)) - (meta (ref p '__class__)) + (meta (rawref p '__class__)) (mro (ref meta '__mro__ '()))) (let lp2 ((max max) (mr (reverse mro))) (if (and (pair? max) (pair? mr)) @@ -886,10 +921,24 @@ explicitly tell it to not update etc. (lp (cdr l) max mro) (lp (cdr l) max min)) (lp (cdr l) mro min))))) - (car (reverse min)))))))) + (if (null? min) + type + (car (reverse min))))))))) + (define (unique l) + (define t (make-hash-table)) + (let lp ((l l)) + (if (pair? l) + (let ((c (car l))) + (if (hashq-ref t c) + (lp (cdr l)) + (begin + (hashq-set! t c #t) + (cons c (lp (cdr l)))))) + '()))) - (define goops (make-class (append goopses - (list (kw->class kw meta))) + (define goops (make-class (unique + (append goopses + (list (kw->class kw meta)))) '() #:name name)) (define (make-module) @@ -912,21 +961,17 @@ 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)) (pylist-set! dict '__module__ (make-module)) (pylist-set! dict '__bases__ (filt-bases parents)) - (pylist-set! dict '__fget__ #t) - (pylist-set! dict '__fset__ #t) (pylist-set! dict '__name__ name) (pylist-set! dict '__qualname__ name) - (pylist-set! dict '__class__ meta) (pylist-set! dict '__mro__ (get-mro cparents)) (pylist-set! dict '__doc__ doc) + (pylist-set! dict '__class__ meta) dict) (let ((cl (with-fluids ((*make-class* #t)) @@ -1047,10 +1092,9 @@ explicitly tell it to not update etc. (make-p-class 'name doc parents (lambda (dict) - (begin - (pylist-set! dict 'dname dname)) + (pylist-set! dict 'dname dname) ... - (values))))) + dict)))) (begin (module-define! (current-module) 'ddname dname) (name-object ddname)) @@ -1101,24 +1145,36 @@ explicitly tell it to not update etc. (else 'none))) -(define (print o l) - (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T"))) - (define port (if (pair? l) (car l) #t)) - (format port "~a" - (aif it (if (pyclass? o) - #f - (if (pyobject? o) - (ref o '__repr__) - #f)) - (format - #f "~a(~a)<~a>" - p (get-type o) (it)) - (format - #f "~a(~a)<~a>" - p (get-type o) (ref o '__name__ 'Annonymous))))) - -(define-method (write (o

) . l) (print o l)) -(define-method (display (o

) . l) (print o l)) +(define (print o l z) + (begin + (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T"))) + (define port (if (pair? l) (car l) #t)) + (format port "~a" + (aif it (if (pyclass? o) + #f + (if (pyobject? o) + z + #f)) + (format + #f "~a(~a)<~a>" + p (get-type o) (it)) + (format + #f "~a(~a)<~a>" + p (get-type o) (aif it (find-in-class-raw + o '__name__ 'Annonymous) + it + (ref + o '__name__ 'Annonymous))))))) + +(define-method (write (o

) . l) + (aif it (ref o '__repr__) + (print o l it) + (print o l #f))) + +(define-method (display (o

) . l) + (aif it (ref o '__repr__) + (print o l it) + (print o l #f))) (define (arglist->pkw l) (let lp ((l l) (r '())) @@ -1152,7 +1208,7 @@ explicitly tell it to not update etc. (define type-goops #f) (define (kind x) - (if (not type-goops) (set! type-goops (ref type '__goops__))) + (if (not type-goops) (set! type-goops (rawref type '__goops__))) (and (is-a? x

) (aif it (find-in-class x '__goops__ #f) (if (or @@ -1181,7 +1237,6 @@ 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 )) @@ -1191,21 +1246,18 @@ explicitly tell it to not update etc. (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)))) + (kif it (ficap c key fail) + (aif dt (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 ((ll (pk 'l class (ref (ref obj '__class__) '__mro__ '())))) + (let ((ll (ref (ref obj '__class__) '__mro__ '()))) (if (pair? ll) (let lp ((l ll)) (if (pair? l) @@ -1378,40 +1430,45 @@ explicitly tell it to not update etc. (hash-fold (lambda (k v s) (cons k s)) '() h)) '())) +(define ref-class + (lambda (self key fail) + (aif class (find-in-class-raw self '__class__ #f) + (kif it1 (ficap class key fail) + (aif dd1 (rawref it1 '__get__) + (dd1 self class) + it1) + fail) + fail))) + (define __getattribute__ - (case-lambda - ((self key) - (define (-fail class) - (if (eq? key 'mro) - (find-in-class self '__mro__ fail) - fail)) - - (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) - (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 (self key-) + (define key (if (string? key-) (string->symbol key-) key-)) + (aif class (find-in-class-raw self '__class__ #f) + (kif it1 (ficap class key fail) + (aif dd1 (rawref it1 '__get__) + (if (rawref it1 '__set__) + (dd1 self class) + (kif it2 (ficap self key fail) + it2 + (dd1 self class))) + (kif it2 (ficap self key fail) + it2 + it1)) + (kif it2 (ficap self key fail) + it2 + (aif it (ficap-raw class '__getattr__ #f) + (kif it1 (catch #t + (lambda () + (it self (symbol->string key))) (lambda x fail)) - (aif dd1 (rawref it1 '__get__) - (pkk 'getattr-gox key (dd1 self class)) - (pkk 'getattr key it1)) - (pkk 'fail1 (-fail class))) - (pkk 'fail2 (-fail class))))) - (pkk 'classfail fail))))) - + (aif dd1 (rawref it1 '__get__) + (dd1 self class) + it1) + fail) + fail))) + fail))) + (define attr __getattribute__) (define (*str* self) @@ -1434,6 +1491,7 @@ explicitly tell it to not update etc. (define mro (lambda (self) (ref self '__mro__))))) (set type '__class__ type) +(rawset type '__mro__ (list type)) (define _mro (object-method (lambda (self) (ref self '__mro__)))) @@ -1441,6 +1499,11 @@ explicitly tell it to not update etc. (set! object (make-python-class object () + (define __new__ (lambda (class . a) + (make-object + class + (find-in-class-raw class '__class__ #f) + (find-in-class-raw class '__goops__ #f)))) (define __init__ (lambda x (values))) (define __subclasses__ subclasses) (define __getattribute__ attr) @@ -1449,7 +1512,8 @@ explicitly tell it to not update etc. (define __format__ (lambda (self x) (*str* self))) (define __reduce_ex__ (lambda x (error "not implemented"))) (define __weakref__ (lambda (self) self)))) - + +(rawset object '__mro__ (list object)) (name-object type) (name-object object) @@ -1467,7 +1531,7 @@ explicitly tell it to not update etc. (if (eq? x 'None) (py-dict NoneObj) (make-hash-table))) - + (define-method (py-dict (o

)) (aif it (ref o '__dict__) it -- cgit v1.2.3