abc
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 28 Mar 2018 13:18:50 +0000 (15:18 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 28 Mar 2018 13:18:50 +0000 (15:18 +0200)
modules/language/python/dict.scm
modules/language/python/exceptions.scm
modules/language/python/for.scm
modules/language/python/module/abc.scm [new file with mode: 0644]
modules/language/python/module/functools.scm
modules/language/python/module/python.scm
modules/language/python/module/weakref.scm
modules/language/python/set.scm
modules/oop/pf-objects.scm

index 6f5e381f3917c9bb520dc6df942b4c08f8afabca..a23428110557e1e73b2bd50ce25eda6be7d0dc8e 100644 (file)
@@ -19,6 +19,8 @@
             py-hash-ref dict pyhash-listing
            weak-key-dict weak-value-dict
            py-hash-ref py-hash-set!
+           make-py-weak-key-hashtable
+           make-py-weak-value-hashtable
             ))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
index 0b91293a17ff6d35ebb147f1bc7b029a12ca5c18..b12f89b74f53627e2c4f270acf81423a660b9067 100644 (file)
@@ -6,7 +6,8 @@
                           IndexError KeyError AttributeError
                           SyntaxError SystemException
                           OSError ProcessLookupError PermissionError
-                          None NotImplemented NotImplementedError))
+                          None NotImplemented NotImplementedError
+                         RunTimeError))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
@@ -25,6 +26,7 @@
 (define ProcessLookupError  'ProcessLookupError)
 (define PermissionError     'PermissionError)
 (define NotImplementedError 'NotImplementedError)
+(define RunTimeError        'RunTimeError)
 
 (define-python-class Exception ()
   (define __init__
index bf37bad52a013d34b41f5417a59b07740241fa5e..50e6ec4024230cfa9eae68b75d087658f3889530 100644 (file)
@@ -52,6 +52,7 @@
                      (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...)))
                      (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))
                      ((N ...)        (map length #'((x ...) ...)))
+                    (M              (length #'(c ...)))
                      (else-          (datum->syntax #'for 'else-))
                      (llp            (if (syntax->datum #'lp) #'lp #'lpu)))
          
@@ -75,7 +76,7 @@
                        (call-with-values
                            (lambda () (next It))
                          (let ((f
-                                (lambda (x2 ...)
+                                (lambda (x2 ... . ll)
                                   (set! x1 x2) ...)))
                            (if (> N 1)
                                (case-lambda
@@ -96,7 +97,7 @@
                            #,(wrap-continue
                              #'lp
                              #'((let ((x x) ... ...) code ...)))
-                         (lambda (cc ... . q) (llp cc ...)))))
+                        (lambda (cc ... . q) (llp cc ...)))))
                    (lambda q (else-) fin)))))))))))
 
 (define-class <scm-list>   () l)
diff --git a/modules/language/python/module/abc.scm b/modules/language/python/module/abc.scm
new file mode 100644 (file)
index 0000000..f0b8442
--- /dev/null
@@ -0,0 +1,167 @@
+(define-module (language python module abc)
+  #:use-module (language python module weakref)
+  #:use-module (oop pf-objects)
+  #:use-module (ice-9 control)
+  #:use-module (language python for)
+  #:use-module (language python try)
+  #:use-module (language python dict)
+  #:use-module (language python set)
+  #:use-module (language python string)
+  #:use-module (language python list)
+  #:use-module (language python def)
+  #:use-module (language python bool)
+  #:use-module (language python exceptions)
+  #:use-module (language python property)
+  #:use-module ((language python module python)
+               #:select (objectmethod classmethod staticmethod type
+                                      isinstance super issubclass
+                                      getattr sorted dir))
+  
+  #:export (get_cache_token ABC ABCMeta
+                           abstractmethod abstractclassmethod
+                           abstractstaticmethod abstractproperty
+                           get_cache_token))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define (abstractmethod f)
+  (set f '__isabstractmethod__ #t)
+  (objectmethod f))
+
+
+(define (abstractclassmethod f)
+  (set f '__isabstractmethod__ #t)
+  (classmethod f))
+
+(define (abstractstaticmethod f)
+  (set f '__isabstractmethod__ #t)
+  f)
+
+(define (abstractproperty f)
+  (let ((f (property f)))
+    (set f '__isabstractmethod__ #t)
+    f))
+  
+(define-python-class ABCMeta (type)
+  (define _abc_invalidation_counter 0)
+
+  (define __new__
+    (lam (mcls name bases namespace (** kwargs))
+        (let ((cls (py-apply (ref (super *class* mcls) '__new__)
+                             mcls name bases namespace (** kwargs)))
+              
+              (abstracts
+               (py-set
+                (append (list name)
+                        (for ((name value : (py-items namespace))) ((l '()))
+                             (if (ref value '__isabstractmethod__)
+                                 (cons name l)
+                                 l)
+                             #:final (reverse l))))))
+
+          (for ((base : bases)) ()
+               (for ((name : (ref base '__abstractmethods__ (py-set '())))) ()
+                    (let ((value (getattr cls name None)))
+                      (if (ref value '__isabstractmethod__)
+                          ((ref abstracts 'add) name)))))
+
+          (set cls '__abstractmethods__ (frozenset abstracts))
+          (set cls '_abc_registry       (WeakSet))
+          (set cls '_abc_cache          (WeakSet))
+          (set cls '_abc_negative_cache (WeakSet))
+          (set cls '_abc_negative_cache_version _abc_invalidation_counter)
+
+          cls)))
+  
+  (define register
+    (lambda (cls subclass)
+      (if (not (isinstance subclass type))
+         (raise TypeError "Can only register classes"))
+      
+      (if (issubclass subclass cls)
+         subclass
+         (if (issubclass cls subclass)
+             (raise RuntimeError "Refusing to create an inheritance cycle")
+             (begin
+               ((ref (ref cls '_abc_registry) 'add) subclass)
+               (set ABCMeta '_abc_invalidation_counter
+                    (+ (ref ABCMeta '_abc_invalidation_counter) 1))
+               subclass)))))
+
+  (define _dump_registry
+    (lam (cls (= file None))
+      (define port (if (eq? file None) #t file))
+      (format port "Class: ~a.~a~%"
+             (ref cls '__module__) (ref cls '__name__))
+      (format port "Inv.counter: ~a~%" (ref ABCMeta '_abc_invalidation_counter))
+      (for ((name : (sorted (dir cls)))) ()
+          (if (py-startswith name "_abc_")
+              (let ((value (getattr cls name)))
+                (format port "~a: ~a~%" name value))))))
+
+  (define __instancecheck__
+    (lambda (cls instance)
+      (let ((subclass (ref instance '__class__)))
+        (if (in subclass (ref cls '_abc_cache))
+            #t
+           (let ((subtype (type instance)))
+             (if (eq? subtype subclass)
+                 (if (and (= (ref cls '_abc_negative_cache_version)
+                             (ref ABCMeta '_abc_invalidation_counter))
+                          (in subclass (ref cls '_abc_negative_cache)))
+                     #f
+                     ((ref cls '__subclasscheck__) subclass))
+                 (or ((ref cls '__subclasscheck__) subclass)
+                     ((ref cls '__subclasscheck__) subtype))))))))
+
+  (define __subclasscheck__
+    (lambda (cls subclass)
+      (let/ec ret
+       (cond
+        ((in subclass (ref cls '_abc_cache))
+         (ret #t))
+        ((< (ref cls '_abc_negative_cache_version)
+            (ref ABCMeta '_abc_invalidation_counter))
+
+         (set cls '_abc_negative_cache (WeakSet))
+         (set cls '_abc_negative_cache_version
+              (ref ABCMeta '_abc_invalidation_counter)))
+        ((in subclass (ref cls '_abc_negative_cache))
+         (ret #f)))
+
+       (aif it (ref cls '__subclasshook__)
+            (let ((ok (it subclass)))
+              (if (not (eq? ok NotImplemented))
+                  (begin
+                    (if (bool ok)
+                        ((ref (ref cls '_abc_cache) 'add) subclass)
+                        ((ref (ref cls '_abc_negative_cache) 'add) subclass)))
+                  (ret (bool ok))))
+            #f)
+       
+        
+        (if (in cls (ref subclass '__mro__ '()))
+            (begin
+             ((ref (ref cls '_abc_cache) 'add) subclass)
+             (ret #t)))
+
+       (for ((rcls : (ref cls '_abc_registry))) ()
+            (when (issubclass subclass rcls)
+                  ((ref (ref cls '_abc_cache) 'add) subclass)
+                  (ret #t)))
+
+       (aif it (ref cls '__subclasses__)
+            (for ((scls : (it))) ()
+                 (when (issubclass subclass scls)
+                       ((ref (ref cls '_abc_cache) 'add) subclass)
+                       (ret #t)))
+            #f)
+
+       ((ref (ref cls '_abc_negative_cache) 'add) subclass)
+       #f))))
+
+(define-python-class ABC (#:metaclass ABCMeta))
+
+
+(define (get_cache_token)
+   (ref ABCMeta '_abc_invalidation_counter))
index 5f2bd5e31055f1e369c42828e0e3b18436f9b3d1..e2a5ce17b8f4fdd516a823d4292eb52a77c541cd 100644 (file)
@@ -9,7 +9,8 @@
   #:use-module (language python module collections)
   #:use-module ((language python module python)
                #:select (iter getattr setattr repr isinstance callable
-                              bool str int))
+                              bool str int enumerate reversed hasattr
+                              issubclass any))
   #:use-module (language python list)
   #:use-module (language python dict)
   #:use-module (language python set)
     (set wrapper 'cache_clear cache_clear)
     wrapper))
 
-#|
+
 ;; single dispatch
 (define (_c3_merge sequences)
   (let lp ((result '()))
     (set! sequences (for ((s : sequences)) ((l '()))
                         (if (bool s)
-                            (cond s l)
+                            (cons s l)
                             l)
                         #:final (reverse l)))
     (if (bool sequences)
                     (let ((cand (pylist-ref (car s1) 0)))
                       (let lp3 ((s2 sequences))
                         (if (pair? s2)
-                            (if (in cand (pylist-slice! (car s2) 1 None None))
+                            (if (in cand (pylist-slice (car s2) 1 None None))
                                 (lp2 (cdr s1))
                                 (lp3 (cdr s2)))
                             cand)))
        (py-list (reverse result)))))
 
 (def (_c3_mro cls (= abcs None))
-    "Computes the method resolution order using extended C3 linearization.
-
-    If no *abcs* are given, the algorithm works exactly like the built-in C3
-    linearization used for method resolution.
-
-    If given, *abcs* is a list of abstract base classes that should be inserted
-    into the resulting MRO. Unrelated ABCs are ignored and don't end up in the
-    result. The algorithm inserts ABCs where their functionality is introduced,
-    i.e. issubclass(cls, abc) returns True for the class itself but returns
-    False for all its direct base classes. Implicit ABCs for a given class
-    (either registered or inferred from the presence of a special method like
-    __len__) are inserted directly after the last ABC explicitly listed in the
-    MRO of said class. If two implicit ABCs end up next to each other in the
-    resulting MRO, their ordering depends on the order of types in *abcs*.
-
-    "
     (define bases (ref cls '__bases__ '()))
     (define boundary
       (for ((i base : (enumerate (reversed bases)))) ()
                  (not (any (map (lambda (b) (issubclass b base)) bases))))
             (pylist-append! abstract_bases base)))
 
-    (for ((base : abstract_bases))
+    (for ((base : abstract_bases)) ()
         (pylist-remove! abcs base))
     
     (let* ((f (lambda (bases)
          abstract_c3_mros
          other_c3_mros
          (py-list explicit_bases)
-         (py-lit abstract_bases)
+         (py-list abstract_bases)
          (py-list other_bases)))))
 
 (define (_compose_mro cls types)
                       (if (is_related n)
                           (cons n l)
                           l)
-                      #final (reverse l)))
+                      #:final (reverse l)))
     
     ;; Remove entries which are strict bases of other entries (they will end up
     ;; in the MRO anyway.
                        (if (is_strict_base n)
                           (cons n l)
                           l)
-                      #final (reverse l)))
+                      #:final (reverse l)))
     
     ; Subclasses of the ABCs in *types* which are also implemented by
     ; *cls* can be used to stabilize ABC ordering.
     
     (for ((typ : types)) ()
         (let ((found (py-list)))
-          (for ((sub in ((ref typ '__subclasses__ (lambda () '()))))) ()
+          (for ((sub : ((ref typ '__subclasses__ (lambda () '()))))) ()
                (if (and (not (in sub bases))
                         (issubclass cls sub))
-                   (pylist-append found
-                                  (for ((s in (ref sub '__mro__ '())))
-                                       ((l '()))
-                                     (if (in s type_set)
-                                         (cons s l)
-                                         l)
-                                     #:final (py-list (reverse l))))))
-          (f (not (bool found))
-             (begin
-               (pylist-append! mro typ)
-               (pylist-sort! found #:key len #:reverse #t)
-               (for ((sub : found)) ()
-                    (for ((subcls : sub)) ()
-                         (if (not (in subcls mro))
-                             (pylist-append! mro subcls))))))))
+                   (pylist-append! found
+                                   (for ((s : (ref sub '__mro__ '())))
+                                        ((l '()))
+                                        (if (in s type_set)
+                                            (cons s l)
+                                            l)
+                                        #:final (py-list (reverse l))))))
+          (if (not (bool found))
+              (begin
+                (pylist-append! mro typ)
+                (pylist-sort! found #:key len #:reverse #t)
+                (for ((sub : found)) ()
+                     (for ((subcls : sub)) ()
+                          (if (not (in subcls mro))
+                              (pylist-append! mro subcls))))))))
 
     (_c3_mro cls #:abcs mro))
 
     
     (py-get registry match))
 
+(define (get_cache_token) #t)
+
 (define (singledispatch func)
     "Single-dispatch generic function decorator.
 
             (let ((current_token (get_cache_token)))
              (if (not (equal? cache_token current_token))
                  (begin
-                   (pylist-clear! dispatch_cache)
+                   (py-clear dispatch_cache)
                    (set! cache_token current_token)))))
 
        (let ((impl (try
              (if (and (eq? cache_token None)
                       (ref cls '__abstractmethods__))
                  (set! cache_token (get_cache_token)))
-             (pylist-clear! dispatch_cache)
+             (py-clear dispatch_cache)
              func)))
 
     (def (wrapper (* args) (** kw))
     (update_wrapper wrapper func)
 
     wrapper)
-|#
+
index 2b1e368ccc4c899bfa62eada9d425569f5471be2..99db1c21712a75ecb0c295a78a9748d00e0ce1a1 100644 (file)
@@ -4,7 +4,8 @@
   #:use-module (ice-9 readline)
   #:use-module ((oop pf-objects) #:select
                 (<p> <property> class-method static-method ref
-                     py-super-mac type object pylist-ref))
+                     py-super-mac type object pylist-ref define-python-class
+                    object-method))
   #:use-module (language python exceptions       )
   #:use-module ((language python module string   ) #:select ())
   #:use-module (language python def              )
   
   #:export (print repr complex float int str
                   set all any bin callable reversed
-                  chr classmethod staticmethod
+                  chr classmethod staticmethod objectmethod
                   divmod enumerate filter open
                   getattr hasattr setattr hex isinstance issubclass
                   iter map sum id input oct ord pow super
-                  sorted zip))
+                  sorted zip
+                 ClassMethod StaticMethod Funcobj))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
@@ -87,6 +89,7 @@
 
 (define chr integer->char)
 
+(define objectmethod object-method)
 (define classmethod  class-method)
 (define staticmethod static-method)
 
 
 (define-method (issubclass (sub <p>) (cls <p>))
   (aif it (ref cls '__subclasscheck__)
-       (it sub)
-       (is-a? (ref sub '__goops__) (ref cls '__goops__))))
+       (it cls sub)
+       (if (eq? sub cls)
+          #t
+          (is-a? (ref sub '__goops__) (ref cls '__goops__)))))
 
 (define-method (isinstance (o <p>) (cl <p>))
   (aif it (ref cl '__instancecheck__)
           (setvbuf port 'block buffering)))
 
        port))
+
+
+(define-python-class ClassMethod  ())
+(define-python-class StaticMethod ())
+(define-python-class Funcobj      ())
      
            
      
index 61f845a229c8d94351bbb2e4b187cf63333d0800..bd7b7ddfc70688e4bd1669e4800b9d66212a792e 100644 (file)
@@ -1,10 +1,11 @@
 (define-module (language python module weakref)
   #:use-module (language python dict)
-  #:export (WeakKeyDictionary WeakValueDictionary))
+  #:use-module (language python set)
+  #:export (WeakKeyDictionary WeakValueDictionary WeakSet))
 
 (define WeakKeyDictionary   weak-key-dict)
 (define WeakValueDictionary weak-value-dict)
-
+(define WeakSet             weak-set)
   
 
   
index d5d36f6eaa5f282fdd71d2248dffa33c38b675ca..5582d36b1e0e45f59e9887f8cddb241c51b15610 100644 (file)
@@ -9,7 +9,7 @@
   #:use-module (language python yield)
   #:use-module (language python persist)
   #:use-module (language python bool)
-  #:export (py-set frozenset))
+  #:export (py-set frozenset weak-set))
 
 (define-class <set> () dict)
 (name-object <set>)
@@ -30,7 +30,8 @@
 
 
 (define miss (list 'miss))
+
+(define-syntax-rule (mk set make-py-hashtable)
 (define-python-class set (<set>)
   (define __init__
     (case-lambda
        (equal? (ref self 'd 1)      (ref x 'd 2)))))
                  
   (define __iter__
-    (make-generator (self)
-        (lambda (yield self)
-          (for ((k v : (slot-ref self 'dict))) ()
-               (yield k)
-               (values))))))
+    (lambda (self)
+      ((make-generator ()
+         (lambda (yield)
+           (for ((k v : (slot-ref self 'dict))) ()
+                (yield k)
+                (values)))))))))
+
+(mk set      make-py-hashtable)
+(mk weak-set make-py-weak-key-hashtable)
 
 (define py-set set)
 (define-python-class frozenset (set))
index b239fc2cf3167de71623aa26eec46976bfe5cfbd..0c82dfe6aa01a0f94397afaa7b5626293bb365c2 100644 (file)
@@ -90,7 +90,7 @@ explicitly tell it to not update etc.
 
 (define (mk-getter-object f)
   (lambda (obj cls)
-    (if (eq? obj cls)
+    (if (or (pyclass? obj) (pytype? obj))
        (lambda x (apply f x))
        (lambda x (apply f obj x)))))
 
@@ -159,30 +159,33 @@ explicitly tell it to not update etc.
 
 (define (hashforeach a b) (values))
 
+(define (new-class0 meta name parents dict . kw)
+  (let* ((goops (pylist-ref dict '__goops__))
+        (p     (kwclass->class kw meta))
+        (class (make-p p)))
+    (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))
+        dict)
+       (hashforeach
+        (lambda (k v) k (set class k v))
+        dict))
+    (let((mro (ref class '__mro__)))
+      (if (pair? mro)
+         (let ((p (car mro)))
+           (aif it (ref p '__init_subclass__)
+                (apply it class #f kw)
+                #f))))
+    (set class '__mro__ (cons class (ref class '__mro__)))
+    class))
+
 (define (new-class meta name parents dict kw)
   (aif it (ref meta '__new__)
-       (apply it name parents dict kw)
-       (let* ((goops (pylist-ref dict '__goops__))
-              (p     (kwclass->class kw meta))
-              (class (make-p p)))
-        (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))
-              dict)
-             (hashforeach
-              (lambda (k v) k (set class k v))
-              dict))
-         (let((mro (ref class '__mro__)))
-           (if (pair? mro)
-               (let ((p (car mro)))
-                 (aif it (ref p '__init_subclass__)
-                      (apply it class #f kw)
-                      #f))))
-         (set class '__mro__ (cons class (ref class '__mro__)))
-         class)))
+       (apply it meta name parents dict kw)
+       (apply new-class0 meta name parents dict kw)))
 
 (define (type- meta name parents dict keys)
   (let ((class (new-class meta name parents dict keys)))
@@ -657,17 +660,11 @@ explicitly tell it to not update etc.
 
 (define (defaulter d)
   (if d
-      (cond
-       ((is-a? d <pyf>)
-        <pyf>)
-       ((is-a? d <py>)
-        <py>)
-       ((is-a? d <pf>)
-        <pf>)
-       ((is-a? d <p>)
-        <p>)
-       (else
-        d))
+      (aif it (ref d '__goops__)
+          it
+          (if (is-a? d <py>)
+              <py>
+              <p>))
       <py>))
 
 (define (kwclass->class kw default)
@@ -696,6 +693,7 @@ explicitly tell it to not update etc.
                       <pyf>
                       <py>)
                   (defaulter default))))))
+
 (define type   #f)
 (define object #f)
 (define (make-p-class name supers.kw methods)
@@ -714,7 +712,7 @@ explicitly tell it to not update etc.
                         p)))
   
   (define meta (aif it (memq #:metaclass kw)
-                    (car it)
+                    (cadr it)
                     (if (null? parents)
                         type
                         (let* ((p   (car parents))
@@ -902,11 +900,15 @@ explicitly tell it to not update etc.
         (cons (reverse r) '()))))
 
 (define-syntax-rule (define-python-class name (parents ...) code ...)
-  (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
+  (define name
+    (syntax-parameterize ((*class* (lambda (x) #'name)))
+       (mk-p-class name (arglist->pkw (list parents ...)) code ...))))
 
 (define-syntax-rule (define-python-class-noname name (parents ...) code ...)
-  (define name (mk-p-class-noname name (arglist->pkw (list parents ...))
-                                 code ...)))
+  (define name
+    (syntax-parameterize ((*class* (lambda (x) #'name)))
+      (mk-p-class-noname name (arglist->pkw (list parents ...))
+                        code ...))))
 
 
 (define-syntax make-python-class
@@ -945,27 +947,32 @@ explicitly tell it to not update etc.
 (define (not-a-super) 'not-a-super)
 (define (py-super class obj)
   (define (make cl parents)
-    (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 (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)))
   
   (call-with-values
       (lambda ()
-        (let lp ((l (ref (ref obj '__class__) '__mro__ '())))
+        (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)))
@@ -1105,6 +1112,7 @@ explicitly tell it to not update etc.
 
 (set! type
       (make-python-class type ()
+       (define __new__ new-class0)              
         (define __call__
           (case-lambda
             ((meta obj)