diff options
author | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2018-04-15 22:29:50 +0200 |
---|---|---|
committer | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2018-04-15 22:29:50 +0200 |
commit | 77e4e51a919c50e2847527aaffe67e8e19b970ae (patch) | |
tree | 61a261e5b053da07493610b947fd8b51e1a8c2f4 /modules | |
parent | 7c0c098b89dc33ad1018b6542def4e2d34ddd2a8 (diff) |
progressively imporoving the conformance with python3
Diffstat (limited to 'modules')
-rw-r--r-- | modules/language/python/compile.scm | 234 | ||||
-rw-r--r-- | modules/language/python/def.scm | 7 | ||||
-rw-r--r-- | modules/language/python/dict.scm | 66 | ||||
-rw-r--r-- | modules/language/python/exceptions.scm | 3 | ||||
-rw-r--r-- | modules/language/python/module/enum.py | 50 | ||||
-rw-r--r-- | modules/language/python/module/python.scm | 4 | ||||
-rw-r--r-- | modules/language/python/number.scm | 60 | ||||
-rw-r--r-- | modules/language/python/set.scm | 16 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 328 |
9 files changed, 484 insertions, 284 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index fc4a1c7..a54dab8 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -44,7 +44,9 @@ (define-syntax-rule (use a ...) (catch #t (lambda () (use-modules a ...)) - (lambda x (raise (ImportError '(a ...)))))) + (lambda x + (warn "failed to load " x) + (raise (ImportError '(a ...)))))) (define s/d 'set!) @@ -213,21 +215,36 @@ (union vs (list (exp '() (if as as (car ids))))))) vs))) - ((#:expr-stmt l (#:assign u)) - (union (fold (lambda (x s) - (match x - ((#:test (#:power v2 v1 () . _) . _) - (if v2 - (union - (union (list (exp '() v1)) - (list (exp '() v2))) - s) - (union (list (exp '() v1)) s))) - (_ s))) - '() - l) - vs)) + ((#:expr-stmt l (#:assign u ... v)) + (union + (fold (lambda (l s) + (union + s + (fold (lambda (x s) + (match x + ((#:test (#:power v2 v1 () . _) . _) + (if v2 + (union + (union (list (exp '() v1)) + (list (exp '() v2))) + s) + (union (list (exp '() v1)) s))) + (_ s))) + '() + l))) + '() + (cons l u)) + vs)) + + ((#:for es in code . final) + (let ((vs (let lp ((es es)) + (match es + (((#:power #f (#:tuple . l) . _)) + (lp l)) + (_ (union vs (map (g vs exp) es))))))) + (scope final (scope code vs)))) + ((#:expr-stmt l (#:assign k . u)) (union (union (fold (lambda (x s) @@ -248,7 +265,7 @@ ((x . y) (scope y (scope x vs))) (_ vs))) - + (define (defs x vs) (match x ((#:def (#:identifier f) . _) @@ -515,14 +532,14 @@ #:final (reverse l))) -(define (arglist->pkw . l) +(define (arglist->pkw l) (let lp ((l l) (r '())) (if (pair? l) (let ((x (car l))) - (if (keyword? x) - (cons (reverse r) l) - (lp (cdr l) (cons x r)))) - (cons (reverse l) '())))) + (if (keyword? x) + (list (G 'cons) `(,(G 'list) ,@(reverse r)) `(,(G 'list) ,@l)) + (lp (cdr l) (cons x r)))) + (list (G 'cons) `(,(G 'list) ,@(reverse r)) ''())))) (define (get-addings vs x) (match x @@ -892,6 +909,12 @@ ((_ class parents code) (with-fluids ((is-class? #t)) (let () + (define (clean l) + (match l + (((#:apply . l). u) (append (clean l) (clean u))) + (((`= x v ) . l) (cons* (symbol->keyword x) v (clean l))) + ((x . l) (cons x (clean l))) + (() '()))) (let* ((decor (let ((r (fluid-ref decorations))) (fluid-set! decorations '()) r)) @@ -911,7 +934,7 @@ (,(C 'mk-p-class2) ,class ,(if parents - `(,(C 'ref-x) ,(C 'arglist->pkw) ,@parents) + (arglist->pkw (clean parents)) `(,(G 'cons) '() '())) ,(map (lambda (x) `(define ,x #f)) ls) ,(exp vs code)))))))))) @@ -1150,6 +1173,7 @@ (dd* (map cadr *f)) (**f (get-args** vs args)) (dd** (map cadr **f)) + (aa `(,@arg_ ,@*f ,@arg= ,@**f)) (ab (gensym "ab")) (vs (union dd** (union dd* (union dd= (union args vs))))) (ns (scope code vs)) @@ -1174,19 +1198,19 @@ `(set! ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f) + (,(D 'lam) ,aa (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,args + (,(C 'with-self) ,c? ,aa ,(with-fluids ((return r)) (exp ns code)))))))))) `(set! ,f (,(C 'def-decor) ,decor - (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f) + (,(D 'lam) ,aa (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,args + (,(C 'with-self) ,c? ,aa ,(with-fluids ((return r)) (exp ns code)))))))))) @@ -1194,19 +1218,19 @@ `(set! ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f) + (,(D 'lam) ,aa (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,args + (,(C 'with-self) ,c? ,aa ,(with-fluids ((return r)) (mk (exp ns code)))))))))) `(set! ,f (,(C 'def-decor) ,decor - (,(D 'lam) (,@arg_ ,@*f ,@arg= ,@**f) + (,(D 'lam) ,aa (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,args + (,(C 'with-self) ,c? ,aa ,(with-fluids ((return r)) (exp ns code)))))))))))))) @@ -1274,10 +1298,10 @@ (car l) `(,(G 'values) ,@l)))) - ((_ l (#:assign x y . u)) + ((_ a (#:assign b c . u)) (let ((z (gensym "x"))) - `(let ((,x ,(exp vs `(#:expr-stmt1 ((#:verb ,z)) (#:assign ,y . ,u))))) - ,(exp vs `(#:expr-stmt ,x (#:assign ((#:verb ,z)))))))) + `(let ((,z ,(exp vs `(#:expr-stmt1 ,b (#:assign ,c . ,u))))) + ,(exp vs `(#:expr-stmt ,a (#:assign ((#:verb ,z)))))))) ((_ l type) (=> fail) @@ -1340,11 +1364,11 @@ (#:expr-stmt1 - ((_ l (#:assign x y . u)) + ((_ a (#:assign b c . u)) (let ((z (gensym "x"))) - `(let ((,x ,(exp vs `(#:expr-stmt1 ((#:verb ,z)) - (#:assign ,y . ,u))))) - ,(exp vs `(#:expr-stmt ,x (#:assign ((#:verb ,z)))))))) + `(let ((,z ,(exp vs `(#:expr-stmt1 ,b + (#:assign ,c . ,u))))) + ,(exp vs `(#:expr-stmt1 ,a (#:assign ((#:verb ,z)))))))) ((_ l type) (=> fail) @@ -1706,7 +1730,8 @@ (if (pair? a) (let lp ((l a)) (if (pair? l) - (let ((x (car l))) + (begin + (set! x (car l)) (with-sp ((continue (lp (cdr l))) (break (values))) code @@ -1720,10 +1745,10 @@ (if (pair? l) (begin (let/ec continue-ret - (let ((x (car l))) - (with-sp ((continue (continue-ret)) - (break (break-ret))) - code))) + (set! x (car l)) + (with-sp ((continue (continue-ret)) + (break (break-ret))) + code)) (lp (cdr l)))))) (for/adv1 (x) (a) code #f #t))) @@ -1731,12 +1756,13 @@ (if (pair? a) (let/ec break-ret (let ((x (let lp ((l a) (old #f)) - (if (pair? l) - (let ((x (car l))) + (if (pair? l) + (begin + (set! x (car l)) (let/ec continue-ret (with-sp ((continue (continue-ret)) (break (break-ret))) - code)) + code)) (lp (cdr l))) old)))) next)) @@ -1749,13 +1775,15 @@ (lambda (x) (syntax-case x () ((_ (x ...) (in) code #f #f) - (with-syntax ((inv (gentemp #'in))) + (with-syntax ((inv (gentemp #'in)) + ((xx ...) (generate-temporaries #'(x ...)))) #'(let ((inv (wrap-in in))) (catch StopIteration (lambda () (let lp () (call-with-values (lambda () (next inv)) - (lambda (x ...) + (lambda (xx ...) + (set! x xx) ... (with-sp ((break (values)) (continue (values))) code @@ -1763,28 +1791,32 @@ (lambda z (values)))))) ((_ (x ...) (in ...) code #f #f) - (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) + (with-syntax (((inv ...) (generate-temporaries #'(in ...))) + ((xx ...) (generate-temporaries #'(x ...)))) #'(let ((inv (wrap-in in)) ...) (catch StopIteration (lambda () (let lp () (call-with-values (lambda () (values (next inv) ...)) - (lambda (x ...) + (lambda (xx ...) + (set! x xx) ... (with-sp ((break (values)) (continue (values))) - code - (lp)))))) + code + (lp)))))) (lambda z (values)))))) ((_ (x ...) (in) code #f #t) - (with-syntax ((inv (gentemp #'in))) + (with-syntax ((inv (gentemp #'in)) + ((xx ...) (generate-temporaries #'(x ...)))) #'(let ((inv (wrap-in in))) (let lp () (let/ec break-ret (catch StopIteration (lambda () (call-with-values (lambda () (next inv)) - (lambda (x ...) + (lambda (xx ...) + (set! x xx) ... (let/ec continue-ret (with-sp ((break (break-ret)) (continue (continue-ret))) @@ -1793,14 +1825,16 @@ (lambda z (values)))))))) ((_ (x ...) (in ...) code #f #t) - (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) + (with-syntax (((inv ...) (generate-temporaries #'(in ...))) + ((xx ...) (generate-temporaries #'(x ...)))) #'(let ((inv (wrap-in in)) ...) (let lp () (let/ec break-ret (catch StopIteration (lambda () (call-with-values (lambda () (values (next inv) ...)) - (lambda (x ...) + (lambda (xx ...) + (set! x xx) ... (let/ec continue-ret (with-sp ((break (break-ret)) (continue (continue-ret))) @@ -1831,71 +1865,67 @@ (if (syntax->datum #'p) #'(let ((inv (wrap-in in))) (let/ec break-ret - (let ((x #f) ...) - (catch StopIteration - (lambda () - (let lp () - (call-with-values (lambda () (next inv)) - (lambda (xx ...) - (set! x xx) ... - (let/ec continue-ret - (with-sp ((break (break-ret)) - (continue (continue-ret))) - code)) - (lp))))) - (lambda q else))))) - - #'(let ((inv (wrap-in in))) - (let ((x #f) ...) - (let/ec break-ret - (catch StopIteration - (lambda () - (let lp () - (call-with-values (lambda () (next inv)) - (lambda (xx ...) - (set! x xx) ... - (with-sp ((break (break-ret)) - (continue (values))) - code) - (lp))))) - (lambda e else))))))))) - - ((_ (x ...) (in ...) code else p) - (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) - (with-syntax ((get (gen #'(inv ...) #'(x ...))) - ((xx ...) (generate-temporaries #'(x ...)))) - (if (syntax->datum #'p) - #'(let ((inv (wrap-in in)) ...) - (let/ec break-ret - (let ((x #f) ...) (catch StopIteration (lambda () (let lp () - (call-with-values (lambda () get) + (call-with-values (lambda () (next inv)) (lambda (xx ...) (set! x xx) ... (let/ec continue-ret (with-sp ((break (break-ret)) (continue (continue-ret))) - code)) + code)) (lp))))) - (lambda q else))))) + (lambda q else)))) - #'(let ((inv (wrap-in in)) ...) - (let ((x #f) ...) + #'(let ((inv (wrap-in in))) (let/ec break-ret (catch StopIteration (lambda () (let lp () - (call-with-values (lambda () get) + (call-with-values (lambda () (next inv)) (lambda (xx ...) (set! x xx) ... (with-sp ((break (break-ret)) (continue (values))) code) (lp))))) - (lambda e else)))))))))))) - + (lambda e else)))))))) + + ((_ (x ...) (in ...) code else p) + (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) + (with-syntax ((get (gen #'(inv ...) #'(x ...))) + ((xx ...) (generate-temporaries #'(x ...)))) + (if (syntax->datum #'p) + #'(let ((inv (wrap-in in)) ...) + (let/ec break-ret + (catch StopIteration + (lambda () + (let lp () + (call-with-values (lambda () get) + (lambda (xx ...) + (set! x xx) ... + (let/ec continue-ret + (with-sp ((break (break-ret)) + (continue (continue-ret))) + code)) + (lp))))) + (lambda q else)))) + + #'(let ((inv (wrap-in in)) ...) + (let/ec break-ret + (catch StopIteration + (lambda () + (let lp () + (call-with-values (lambda () get) + (lambda (xx ...) + (set! x xx) ... + (with-sp ((break (break-ret)) + (continue (values))) + code) + (lp))))) + (lambda e else))))))))))) + (define-syntax def-wrap (lambda (x) (syntax-case x () @@ -1941,13 +1971,15 @@ (define-syntax ref-x (lambda (x) - (syntax-case x () + (syntax-case x (quote __dict__) ((_ v) #'v) ((_ v (#:fastfkn-ref f _) . l) #'(ref-x (lambda x (if (pyclass? v) (apply f x) (apply f v x))) . l)) ((_ v (#:fast-id f _) . l) #'(ref-x (f v) . l)) + ((_ v (#:identifier '__dict__) . l) + #'(ref-x (py-dict v) . l)) ((_ v (#:identifier x) . l) #'(ref-x (wr x (ref v x miss)) . l)) ((_ v (#:call-obj x) . l) diff --git a/modules/language/python/def.scm b/modules/language/python/def.scm index 5c83b6f..fa4cbc5 100644 --- a/modules/language/python/def.scm +++ b/modules/language/python/def.scm @@ -82,7 +82,12 @@ (ww- (fold get-ww '() #'(arg ...))) (kv (fold get-kv '() #'(arg ...)))) (if (and-map null? (list kw ww- kv)) - #`(object-method (lambda #,as code ...)) + #`(object-method + (lambda (#,@as . u12345678) + (if (and (pair? u12345678) + (not (keyword? (car u12345678)))) + (raise (ArgumentError "too many arguments to function"))) + code ...)) (with-syntax ((kw (if (null? kw) (datum->syntax x (gensym "kw")) (car kw))) diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm index 260aa0d..977d5e1 100644 --- a/modules/language/python/dict.scm +++ b/modules/language/python/dict.scm @@ -44,13 +44,13 @@ (define H (hash 1333674836 complexity)) -(define-class <py-hashtable> () t h n) +(define-class <py-hashtable> () t hash n) (name-object <py-hashtable>) (cpit <py-hashtable> (o (lambda (o h n a) - (slot-set! o 'h h) + (slot-set! o 'hash h) (slot-set! o 'n n) (slot-set! o 't (let ((t (make-hash-table))) @@ -62,7 +62,7 @@ t))) (let ((t (slot-ref o 't))) (list - (slot-ref o 'h) + (slot-ref o 'hash) (slot-ref o 'n) (hash-fold (lambda (k v s) (cons (cons k v) s)) '() t))))) @@ -71,7 +71,7 @@ (t (make-hash-table)) (h H)) (slot-set! o 't t) - (slot-set! o 'h h) + (slot-set! o 'hash h) (slot-set! o 'n 0) o)) @@ -80,7 +80,7 @@ (t (make-weak-key-hash-table)) (h H)) (slot-set! o 't t) - (slot-set! o 'h h) + (slot-set! o 'hash h) (slot-set! o 'n 0) o)) @@ -89,7 +89,7 @@ (t (make-weak-value-hash-table)) (h H)) (slot-set! o 't t) - (slot-set! o 'h h) + (slot-set! o 'hash h) (slot-set! o 'n 0) o)) @@ -152,14 +152,14 @@ (define-method (pyhash-rem! (o <py-hashtable>) k) (let ((t (slot-ref o 't)) (n (slot-ref o 'n)) - (h (slot-ref o 'h))) + (h (slot-ref o 'hash))) (let ((ret (py-hash-ref t k miss))) (if (eq? ret miss) (values) (begin (py-hash-remove! t k) - (slot-set! o 'n (- n 1)) - (slot-set! o 'h (logxor h (xy (py-hash k) (py-hash ret)))) + (slot-set! o 'n (- n 1)) + (slot-set! o 'hash (logxor h (xy (py-hash k) (py-hash ret)))) (values)))))) (define-method (pylist-pop! (o <py-hashtable>) k . l) @@ -187,16 +187,16 @@ (define-method (pylist-set! (o <py-hashtable>) key val) (let ((t (slot-ref o 't)) (n (slot-ref o 'n)) - (h (slot-ref o 'h))) + (h (slot-ref o 'hash))) (let ((ret (py-hash-ref t key miss))) (if (eq? ret miss) (begin (py-hash-set! t key val) (slot-set! o 'n (+ n 1)) - (slot-set! o 'h (logxor (xy (py-hash key) (py-hash val)) h))) + (slot-set! o 'hash (logxor (xy (py-hash key) (py-hash val)) h))) (begin (py-hash-set! t key val) - (slot-set! o 'h + (slot-set! o 'hash (logxor (xy (py-hash key) (py-hash val)) (logxor (xy (py-hash key) (py-hash ret)) @@ -242,7 +242,7 @@ (<py-hashtable> (let ((r (make <py-hashtable>))) - (slot-set! r 'h (slot-ref o 'h)) + (slot-set! r 'hash (slot-ref o 'hash)) (slot-set! r 'n (slot-ref o 'n)) (slot-set! r 't (py-copy (slot-ref o 't))) r))) @@ -275,7 +275,7 @@ (let ((elseval (match l (() None) ((v) v)))) - (let ((ret (py-hash-ref o k miss))) + (let ((ret (ref o k miss))) (if (eq? ret miss) elseval ret)))) @@ -284,7 +284,7 @@ (let ((elseval (match l (() None) ((v) v)))) - (let ((ret (py-hash-ref (slot-ref o 't) k miss))) + (let ((ret (ref (slot-ref o 't) k miss))) (if (eq? ret miss) elseval ret))))) @@ -453,7 +453,7 @@ (let ((t (slot-ref o 't))) (hash-clear! t) (slot-set! o 'n 0) - (slot-set! o 'h H) + (slot-set! o 'hash H) (values)))) #| @@ -492,9 +492,9 @@ (define-method (py-equal? (o1 <py-hashtable>) (o2 <py-hashtable>)) (and - (equal? (slot-ref o1 'n) (slot-ref o2 'n)) - (equal? (slot-ref o1 'h) (slot-ref o2 'h)) - (e? (slot-ref o1 't) (slot-ref o2 't)))) + (equal? (slot-ref o1 'n) (slot-ref o2 'n)) + (equal? (slot-ref o1 'hash) (slot-ref o2 'hash)) + (e? (slot-ref o1 't) (slot-ref o2 't)))) (define (e? t1 t2) (let/ec ret @@ -548,12 +548,12 @@ (letrec ((__init__ (case-lambda ((self) - (let ((r (make-py-hashtable))) - (slot-set! self 't (slot-ref r 't)) - (slot-set! self 'h (slot-ref r 'h)) - (slot-set! self 'n (slot-ref r 'n)))) + (let ((r (make-hash-table))) + (slot-set! self 't r) + (slot-set! self 'hash H) + (slot-set! self 'n 0))) ((self x) - (__init__ self) + (__init__ self) (catch #t (lambda () (for ((k v : x)) () @@ -572,10 +572,11 @@ (letrec ((__init__ (case-lambda ((self) - (let ((r (make-py-weak-key-hashtable))) - (slot-set! self 't (slot-ref r 't)) - (slot-set! self 'h (slot-ref r 'h)) - (slot-set! self 'n (slot-ref r 'n)))) + (let ((r (make-hash-table))) + (slot-set! self 't r) + (slot-set! self 'hash H) + (slot-set! self 'n 0))) + ((self x) (__init__ self) (if (is-a? x <py-hashtable>) @@ -590,10 +591,11 @@ (letrec ((__init__ (case-lambda ((self) - (let ((r (make-py-weak-value-hashtable))) - (slot-set! self 't (slot-ref r 't)) - (slot-set! self 'h (slot-ref r 'h)) - (slot-set! self 'n (slot-ref r 'n)))) + (let ((r (make-hash-table))) + (slot-set! self 't r) + (slot-set! self 'hash H) + (slot-set! self 'n 0))) + ((self x) (__init__ self) (if (is-a? x <py-hashtable>) diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm index 93ce54d..9d51116 100644 --- a/modules/language/python/exceptions.scm +++ b/modules/language/python/exceptions.scm @@ -3,7 +3,7 @@ #:use-module (oop goops) #:export (StopIteration GeneratorExit RuntimeError Exception ValueError TypeError - IndexError KeyError AttributeError + IndexError KeyError AttributeError ArgumentError SyntaxError SystemException OSError ProcessLookupError PermissionError None NotImplemented NotImplementedError @@ -40,6 +40,7 @@ (define-er SystemException 'SystemException) (define-er RuntimeError 'RuntimeError) (define-er IndexError 'IndexError) +(define-er ArgumentError 'IndexError) (define-er ValueError 'ValueError) (define None 'None) (define-er KeyError 'KeyError) diff --git a/modules/language/python/module/enum.py b/modules/language/python/module/enum.py index 89047cd..1549862 100644 --- a/modules/language/python/module/enum.py +++ b/modules/language/python/module/enum.py @@ -11,7 +11,6 @@ try: except ImportError: from collections import OrderedDict - __all__ = [ 'EnumMeta', 'Enum', 'IntEnum', 'Flag', 'IntFlag', @@ -50,6 +49,8 @@ def _make_class_unpicklable(cls): cls.__module__ = '<unknown>' _auto_null = object() + + class auto: """ Instances are replaced with an appropriate value in Enum class suites. @@ -117,10 +118,14 @@ class EnumMeta(type): def __prepare__(metacls, cls, bases): # create the namespace dict enum_dict = _EnumDict() + pk('got dict') + # inherit previous flags and _generate_next_value_ function member_type, first_enum = metacls._get_mixins_(bases) + if first_enum is not None: enum_dict['_generate_next_value_'] = getattr(first_enum, '_generate_next_value_', None) + return enum_dict def __new__(metacls, cls, bases, classdict): @@ -128,42 +133,45 @@ 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). + pk('new enum meta') member_type, first_enum = metacls._get_mixins_(bases) __new__, save_new, use_args = metacls._find_new_(classdict, member_type, first_enum) - + pk(1) # 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] - + pk(2) # adjust the sunders _order_ = classdict.pop('_order_', None) - + pk(3) # check for illegal enum names (any others?) invalid_names = set(enum_members) & {'mro', } if invalid_names: raise ValueError('Invalid enum member name: {0}'.format( ','.join(invalid_names))) - + pk(4) # create a default docstring if one has not been provided if '__doc__' not in classdict: classdict['__doc__'] = 'An enumeration.' - + pk(5) # create our new Enum type enum_class = super().__new__(metacls, cls, bases, classdict) + enum_class._member_names_ = [] # names in definition order enum_class._member_map_ = OrderedDict() # name->value map enum_class._member_type_ = member_type - + pk(6) # 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. enum_class._value2member_map_ = {} - + pk(7) # If a custom type is mixed into the Enum, and it does not know how # to pickle itself, pickle.dumps will succeed but pickle.loads will # fail. Rather than have the error show up later and possibly far @@ -180,7 +188,7 @@ class EnumMeta(type): '__reduce_ex__', '__reduce__') if not any(m in member_type.__dict__ for m in methods): _make_class_unpicklable(enum_class) - + pk(8) # instantiate them, checking for duplicates as we go # we instantiate first instead of checking for duplicates first in case # a custom __new__ is doing something funky with the values -- such as @@ -230,7 +238,7 @@ class EnumMeta(type): enum_class._value2member_map_[value] = enum_member except TypeError: pass - + pk(9) # double check that repr and friends are not the mixin's or various # things break (such as pickle) for name in ('__repr__', '__str__', '__format__', '__reduce_ex__'): @@ -239,7 +247,7 @@ class EnumMeta(type): enum_method = getattr(first_enum, name, None) if obj_method is not None and obj_method is class_method: setattr(enum_class, name, enum_method) - + pk(10) # replace any other __new__ with our own (as long as Enum is not None, # anyway) -- again, this is to support pickle if Enum is not None: @@ -248,14 +256,14 @@ class EnumMeta(type): if save_new: enum_class.__new_member__ = __new__ enum_class.__new__ = Enum.__new__ - + pk(11) # py3 support for definition order (helps keep py2/py3 code in sync) if _order_ is not None: if isinstance(_order_, str): _order_ = _order_.replace(',', ' ').split() if _order_ != enum_class._member_names_: raise TypeError('member order does not match _order_') - + pk(12) return enum_class def __bool__(self): @@ -424,9 +432,10 @@ class EnumMeta(type): bases: the tuple of bases that was given to __new__ """ + pk('bases',bases) if not bases: return object, Enum - + pk(2) # double check that we are not subclassing a class with existing # enumeration members; while we're at it, see if any other data # type has been mixed in so we can use the correct __new__ @@ -436,6 +445,9 @@ class EnumMeta(type): issubclass(base, Enum) and base._member_names_): raise TypeError("Cannot extend enumerations") + pk(3) + pk(base) + pk(bases) # base is now the last base in bases if not issubclass(base, Enum): raise TypeError("new enumerations must be created as " @@ -473,11 +485,12 @@ class EnumMeta(type): # now find the correct __new__, checking to see of one was defined # by the user; also check earlier enum classes in case a __new__ was # saved as __new_member__ + pk(0) __new__ = classdict.get('__new__', None) - + pk(1) # should __new__ be saved as __new_member__ later? save_new = __new__ is not None - + pk(2) if __new__ is None: # check all possibles for __new_member__ before falling back to # __new__ @@ -496,7 +509,7 @@ class EnumMeta(type): break else: __new__ = object.__new__ - + pk(3) # if a non-object.__new__ is used then whatever value/tuple was # assigned to the enum member name will be passed to __new__ and to the # new enum member's __init__ @@ -504,7 +517,7 @@ class EnumMeta(type): use_args = False else: use_args = True - + pk(4) return __new__, save_new, use_args class Enum(metaclass=EnumMeta): @@ -636,6 +649,7 @@ class Enum(metaclass=EnumMeta): module_globals[name] = cls return cls +pk(6) class IntEnum(int, Enum): """Enum where members are also (and must be) ints""" diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index 3398dbb..ef42cc6 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -29,7 +29,7 @@ #:use-module (language python eval ) #:use-module (language python bool ) - #:replace (list abs min max hash round format) + #:replace (list abs min max hash round format map) #:re-export (StopIteration GeneratorExit RuntimeError Exception ValueError TypeError @@ -47,7 +47,7 @@ chr classmethod staticmethod objectmethod divmod enumerate filter getattr hasattr setattr hex isinstance issubclass - iter map sum id input oct ord pow super + iter sum id input oct ord pow super sorted zip ClassMethod StaticMethod Funcobj)) diff --git a/modules/language/python/number.scm b/modules/language/python/number.scm index 6d93435..845a155 100644 --- a/modules/language/python/number.scm +++ b/modules/language/python/number.scm @@ -74,7 +74,7 @@ (define-syntax-rule (mk-biop1 mk-biop0 op r1) (begin (mk-biop0 op) - (define-method (op v (o <p>)) + (define-method (op (o <p>) v) (aif it (ref o 'r1) (it v) (next-method))))) @@ -95,6 +95,7 @@ (define-method (op o2 (o1 <py-int>)) (op o2 (slot-ref o1 'x))))) + (mk-biop2 b0 r+ + __add__ __radd__) (mk-biop2 b0 r- - __sub__ __rsub__) (mk-biop2 b0 r* * __mul__ __rmul__) @@ -106,6 +107,7 @@ (mk-biop2 b0 rexpt expt __pow__ __rpow__) (b0 py-equal?) + (define-method (py-lshift (o1 <integer>) (o2 <integer>)) (ash o1 o2)) (define-method (py-rshift (o1 <integer>) (o2 <integer>)) @@ -123,6 +125,62 @@ (define-method (py-lognot (o1 <integer>)) (lognot o1)) +(define-method (py-logand o1 (o2 <py-int>)) + (py-logand o1 (slot-ref o2 'x))) + +(define-method (py-logand (o1 <py-int>) o2) + (py-logand (slot-ref o1 'x) o2)) + +(define-method (py-logior o1 (o2 <py-int>)) + (py-logior o1 (slot-ref o2 'x))) + +(define-method (py-logior (o1 <py-int>) o2) + (py-logior (slot-ref o1 'x) o2)) + +(define-method (py-logxor o1 (o2 <py-int>)) + (py-logxor o1 (slot-ref o2 'x))) + +(define-method (py-logxor (o1 <py-int>) o2) + (py-logxor (slot-ref o1 'x) o2)) + +(define-method (py-lognot (o1 <py-int>)) + (lognot (slot-ref o1 'x))) + +(define-method (py-logand (o1 <p>) o2) + (aif it (ref o1 '__and__) + (it o2) + (next-method))) + +(define-method (py-logand o1 (o2 <p>)) + (aif it (ref o1 '__rand__) + (it o2) + (next-method))) + +(define-method (py-logior (o1 <p>) o2) + (aif it (ref o1 '__or__) + (it o2) + (next-method))) + +(define-method (py-logior o1 (o2 <p>)) + (aif it (ref o1 '__ror__) + (it o2) + (next-method))) + +(define-method (py-logxor (o1 <p>) o2) + (aif it (ref o1 '__xor__) + (it o2) + (next-method))) + +(define-method (py-logxor o1 (o2 <p>)) + (aif it (ref o1 '__rxor__) + (it o2) + (next-method))) + +(define-method (py-lognot (o1 <p>)) + (aif it (ref o1 '__not__) + (it) + (next-method))) + (define-method (py-/ (o1 <number>) (o2 <integer>)) (/ o1 (exact->inexact o2))) diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm index 5582d36..2f3b7cc 100644 --- a/modules/language/python/set.scm +++ b/modules/language/python/set.scm @@ -224,6 +224,22 @@ (t (slot-ref d 't))) (not (eq? miss (py-hash-ref t x miss)))))) + (define __and__ + (lambda (self op) + (intersection self op))) + + (define __or__ + (lambda (self op) + (union self op))) + + (define __sub__ + (lambda (self op) + (difference self op))) + + (define __xor__ + (lambda (self op) + (symmetric_difference self op))) + (define __eq__ (lambda (self x) (and diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index d42865f..64ad776 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -17,7 +17,7 @@ py-super-mac py-super py-equal? *class* *self* pyobject? pytype? type object pylist-set! pylist-ref tr - resolve-method-g rawref rawset + resolve-method-g rawref rawset py-dict )) #| @@ -34,6 +34,26 @@ The datastructure is functional but the objects mutate. So one need to explicitly tell it to not update etc. |# +(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) (pk k)) h) + (pk 'finished-obj) + (aif cl (hash-ref h '__class__) + (if (is-a? cl <p>) + (if (hash-table? (slot-ref cl 'h)) + (hash-for-each (lambda (k v) + (if (member k '(__name__ __qualname__)) + (pk k v) + (pk k))) + (slot-ref cl 'h)) + (pk 'no-hash-table)) + (pk 'no-class)) + (pk 'false-class))) + (pk 'end-pk-obj)) + (define fail (cons 'fail '())) (define-syntax-rule (kif it p x y) @@ -52,7 +72,6 @@ explicitly tell it to not update etc. (define (is-acl? a b) (member a (cons b (class-subclasses b)))) -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) (define-class <p> (<applicable-struct> <object>) h) (define-class <pf> (<p>) size n) ; the pf object consist of a functional ; hashmap it's size and number of live @@ -88,6 +107,27 @@ explicitly tell it to not update etc. (define-method (rawset (o <procedure>) key val) (set-procedure-property! o key val)) +(define-method (find-in-class (klass <pf>) key fail) + (let ((r (vhash-assoc key (slot-ref klass 'h)))) + (if r + (cdr r) + fail))) + +(define-syntax-rule (find-in-class-and-parents klass key fail-) + (aif parents (find-in-class klass '__mro__ #f) + (let lp ((parents parents)) + (if (pair? parents) + (kif r (find-in-class (car parents) key fail) + r + (lp (cdr parents))) + fail-)) + (kif r (find-in-class klass key fail) + r + fail-))) + +(define-inlinable + (ficap klass key fail) (find-in-class-and-parents klass key fail)) + (define (mk-getter-object f) (lambda (obj cls) (if (pytype? obj) @@ -95,10 +135,10 @@ explicitly tell it to not update etc. (if (pyclass? obj) (if (pytype? cls) (lambda x (apply f obj x)) - (lambda x (apply f x))) + f) (if (pyclass? cls) (lambda x (apply f obj x)) - (lambda x (apply f x))))))) + f))))) (define (mk-getter-class f) (lambda (obj cls) @@ -158,20 +198,17 @@ explicitly tell it to not update etc. (define (resolve-method-o o pattern) (resolve-method-g (class-of o) pattern)) -(define (get-dict self name parents) - (aif it (ref self '__prepare__) - (it self name parents) - (make-hash-table))) - (define (hashforeach a b) (values)) (define (new-class0 meta name parents dict . kw) (let* ((goops (pylist-ref dict '__goops__)) - (p (kwclass->class kw meta)) + (p (kwclass->class kw meta)) (class (make-p p))) + (pk 'new-class0) (slot-set! class 'procedure (lambda x (create-object class meta goops x))) + (if (hash-table? dict) (hash-for-each (lambda (k v) k (set class k v)) @@ -194,7 +231,7 @@ explicitly tell it to not update etc. class)) (define (new-class meta name parents dict kw) - (aif it (ref meta '__new__) + (aif it (and meta (ficap meta '__new__ #f)) (apply it meta name parents dict kw) (apply new-class0 meta name parents dict kw))) @@ -205,31 +242,55 @@ explicitly tell it to not update etc. #f) class)) -(define (create-class meta name parents gen-methods . keys) - (let ((dict (gen-methods (get-dict meta name keys)))) + +(define (the-create-object class x) + (let* ((meta (ref class '__class__)) + (goops (ref class '__goops__)) + (obj (aif it (ficap class '__new__ #f) + (it) + (make-object class meta goops)))) + (aif it (ref obj '__init__) + (apply it x) + #f) + + (slot-set! obj 'procedure + (lambda x + (aif it (ref obj '__call__) + (apply it x) + (error "not a callable object")))) + + obj)) + +(define (create-object class meta goops x) + (with-fluids ((*make-class* #t)) + (aif it (ficap meta '__call__ #f) + (apply it class x) + (the-create-object class x)))) + +(define type-call + (lambda (class . l) + (if (pytype? class) + (apply (case-lambda + ((meta obj) + (ref obj '__class__ 'None)) + ((meta name bases dict . keys) + (type- meta name bases dict keys))) + class l) + (the-create-object class l)))) + +(define (get-dict self name parents) + (aif it (and self (ficap self '__prepare__ #f)) + (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 (ref meta '__class__) - (aif it (find-in-class (ref meta '__class__) '__call__ #f) + (aif it (find-in-class it '__call__ #f) (apply it meta name parents dict keys) (type- meta name parents dict keys)) (type- meta name parents dict keys)))) -(define (create-object class meta goops x) - (with-fluids ((*make-class* #t)) - (aif it #f - (apply it x) - (let ((obj (aif it (find-in-class class '__new__ #f) - (it) - (make-object class meta goops)))) - (aif it (ref obj '__init__) - (apply it x) - #f) - (slot-set! obj 'procedure - (lambda x - (aif it (ref obj '__call__) - (apply it x) - (error "not a callable object")))) - obj)))) - (define (make-object class meta goops) (let ((obj (make-p goops))) (set obj '__class__ class) @@ -272,6 +333,11 @@ explicitly tell it to not update etc. (f obj class) it))) +(define-inlinable (gokx obj class it) + (aif f (rawref it '__get__) + (f obj class) + it)) + (define *location* (make-fluid #f)) (define-syntax-rule (mrefx x key l) (let () @@ -304,30 +370,12 @@ explicitly tell it to not update etc. (define-method (find-in-class (klass <p>) key fail) (hash-ref (slot-ref klass 'h) key fail)) - -(define-method (find-in-class (klass <pf>) key fail) - (let ((r (vhash-assoc key (slot-ref klass 'h)))) - (if r - (cdr r) - fail))) - -(define-syntax-rule (find-in-class-and-parents klass key fail) - (kif r (find-in-class klass key fail) - r - (aif parents (find-in-class klass '__mro__ #f) - (let lp ((parents (cdr parents))) - (if (pair? parents) - (kif r (find-in-class (car parents) key fail) - r - (lp (cdr parents))) - fail)) - fail))) - + (define-syntax-rule (mrefx klass key l) (let () (define (end) (if (pair? l) (car l) #f)) (fluid-set! *location* klass) - (kif it (find-in-class klass key fail) + (kif it (find-in-class-and-parents klass key fail) it (aif klass (find-in-class klass '__class__ #f) (begin @@ -341,26 +389,17 @@ explicitly tell it to not update etc. (define-syntax-rule (mrefx-py x key l) (let ((xx x)) - (let* ((g (mrefx xx '__fget__ '(#t))) - (f (if g - (if (eq? g #t) - (aif it (mrefx xx '__getattribute__ '()) - (let ((f (gox xx it))) - (rawset xx '__fget__ it) - f) - (begin - (if (mc?) - (rawset xx '__fget__ #f)) - #f)) - g) - #f))) - (if (or (not f) (eq? f not-implemented)) - (gox xx (mrefx xx key l)) - (catch #t - (lambda () - (f xx key)) - (lambda x - (gox xx (mrefx xx key l)))))))) + (let* ((f (aif it (or (mrefx xx '__getattribute__ '()) + (mrefx xx '__getattr__ '())) + (gox xx it) + #f))) + (if (or (not f) (eq? f not-implemented)) + (gox xx (mrefx xx key l)) + (catch #t + (lambda () + (f xx key)) + (lambda x + (gox xx (mrefx xx key l)))))))) (define-syntax-rule (mref x key l) @@ -372,7 +411,15 @@ explicitly tell it to not update etc. (let ((res (mrefx-py xx key l))) res))) -(define-method (ref x key . l) (if (pair? l) (car l) #f)) +(define-method (ref x key . l) + (cond + ((eq? x 'None) + (apply ref NoneObj key l)) + ((pair? l) + (car l)) + (else + #f))) + (define-method (ref (x <pf> ) key . l) (mref x key l)) (define-method (ref (x <p> ) key . l) (mref x key l)) (define-method (ref (x <pyf>) key . l) (mref-py x key l)) @@ -712,28 +759,32 @@ explicitly tell it to not update etc. ((name supers.kw methods) (make-p-class name "" supers.kw methods)) ((name doc supers.kw methods) - (define kw (cdr supers.kw)) - (define supers (car supers.kw)) + (define s.kw supers.kw) + (define kw (cdr s.kw)) + (define supers (car s.kw)) (define goopses (map (lambda (sups) (aif it (ref sups '__goops__ #f) it sups)) supers)) + (define parents (let ((p (filter-parents supers))) - (if (null? p) - (if object - (list object) - '()) - p))) + p)) + + (define cparents (if (null? parents) + (if object + (list object) + '()) + parents)) (define meta (aif it (memq #:metaclass kw) (cadr it) - (if (null? parents) + (if (null? cparents) type - (let* ((p (car parents)) + (let* ((p (car cparents)) (m (ref p '__class__)) (mro (reverse (ref m '__mro__ '())))) - (let lp ((l (cdr parents)) + (let lp ((l (cdr cparents)) (max mro) (min mro)) (if (pair? l) @@ -753,7 +804,8 @@ explicitly tell it to not update etc. (lp (cdr l) mro min))))) (car (reverse min)))))))) - (define goops (make-class (append goopses (list (kw->class kw meta))) + (define goops (make-class (append goopses + (list (kw->class kw meta))) '() #:name name)) (define (make-module) @@ -766,33 +818,42 @@ explicitly tell it to not update etc. (map symbol->string (cdddr l)) ".") l))) - + (define (gen-methods dict) + (define (filt-bases x) + (let lp ((x x)) + (if (pair? x) + (let ((y (car x))) + (if (is-a? y <p>) + (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__ parents) + (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 parents)) + (pylist-set! dict '__mro__ (get-mro cparents)) (pylist-set! dict '__doc__ doc) dict) (let ((cl (with-fluids ((*make-class* #t)) - (create-class meta name parents gen-methods kw)))) + (create-class meta name parents gen-methods kw)))) (aif it (ref meta '__init_subclass__) - (let lp ((ps parents)) + (let lp ((ps cparents)) (if (pair? ps) (let ((super (car ps))) (it cl super) (lp (cdr ps))))) #f) - + cl)))) @@ -867,8 +928,8 @@ explicitly tell it to not update etc. (lambda (x) (syntax-case x () ((_ name parents ((ddef dname dval) ...) body) - #'(mk-p-class name parents "" (ddef dname dval) ...)) - ((_ name parents doc (ddef dname dval) ...) + #'(mk-p-class2 name parents "" ((ddef dname dval) ...) body)) + ((_ name parents doc ((ddef dname dval) ...) body) (with-syntax (((ddname ...) (map (lambda (dn) (datum->syntax @@ -894,13 +955,13 @@ explicitly tell it to not update etc. #'(let () (define name (letruc ((dname (make-up dval)) ...) - body - (make-p-class 'name doc - parents - (lambda (dict) - (pylist-set! dict 'dname dname) - ... - (values))))) + body + (make-p-class 'name doc + parents + (lambda (dict) + (pylist-set! dict 'dname dname) + ... + (values))))) (begin (module-define! (current-module) 'ddname (ref name 'dname)) @@ -1001,11 +1062,15 @@ explicitly tell it to not update etc. code ...))) cl))))) - +(define type-goops #f) (define (kind x) + (if (not type-goops) (set! type-goops (ref type '__goops__))) (and (is-a? x <p>) (aif it (find-in-class x '__goops__ #f) - (if (is-a? (make it) (ref type '__goops__)) + (if (or + (not type-goops) + (eq? it type-goops) + (member it (class-subclasses type-goops))) 'type 'class) 'object))) @@ -1028,25 +1093,23 @@ explicitly tell it to not update etc. (define (not-a-super) 'not-a-super) (define (py-super class obj) (define (make cl parents) - (if (or (pyclass? obj) (pytype? obj)) - cl - (let ((c (make-p <p>)) - (o (make-p <p>))) - (set c '__super__ #t) - (set c '__mro__ parents) - (set c '__getattribute__ (lambda (self key . l) - (aif it (ref c key) - (if (procedure? it) - (if (eq? (procedure-property - it - 'py-special) - 'class) - (it cl) - (it obj)) - it) - (error "no attribute")))) - (set o '__class__ c) - o))) + (if (not cl) + #f + (if (or (pyclass? obj) (pytype? obj)) + cl + (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 . l) + (aif it (ficap c key #f) + (if (procedure? it) + (gokx obj cl it) + it) + (error "no attribute")))) + (set c '__name__ "**super**") + (set o '__class__ c) + o)))) (call-with-values (lambda () @@ -1222,17 +1285,16 @@ explicitly tell it to not update etc. (define __init_subclass__ (lambda x (values))) (define ___zub_classes__ (make-weak-key-hash-table)) (define __subclasses__ subclasses) - (define __call__ - (case-lambda - ((meta obj) - (ref obj '__class__ 'None)) - ((meta name bases dict . keys) - (type- meta name bases dict keys)))))) + (define __call__ type-call) + (define mro (lambda (self) (ref self '__mro__))))) + (set type '__class__ type) (set! object (make-python-class object () - (define __subclasses__ subclasses) - (define __weakref__ (lambda (self) self)))) + (define __init__ (lambda x (values))) + (define __subclasses__ subclasses) + (define __weakref__ (lambda (self) self)))) + (name-object type) (name-object object) @@ -1242,4 +1304,14 @@ explicitly tell it to not update etc. it (next-method))) - + +(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))) + + |