summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>2018-04-25 20:00:41 +0200
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>2018-04-25 20:00:41 +0200
commit1b2144cfb35202c05f39f279198a6ad90748be23 (patch)
tree405845e063b778e7b05077dbc66cbc318c5e0c0c
parent70e3ba150960fdbd46c69e00ef6f7437f99966c8 (diff)
improvements
-rw-r--r--modules/language/python/compile.scm88
-rw-r--r--modules/language/python/dict.scm26
-rw-r--r--modules/language/python/for.scm3
-rw-r--r--modules/language/python/list.scm8
-rw-r--r--modules/language/python/module.scm17
-rw-r--r--modules/language/python/module/enum.py31
-rw-r--r--modules/language/python/module/python.scm12
-rw-r--r--modules/oop/pf-objects.scm299
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)))
-