super
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 4 Oct 2017 22:56:12 +0000 (00:56 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 4 Oct 2017 22:56:12 +0000 (00:56 +0200)
modules/language/python/compile.scm
modules/language/python/dict.scm
modules/language/python/list.scm
modules/language/python/module/python.scm
modules/language/python/number.scm
modules/language/python/string.scm
modules/oop/pf-objects.scm

index c9acea10094277351ff8afc0228c3877ff2b6543..c3a64932c77f50a9550e864a8554bd45bf757b48 100644 (file)
 (define fasthash
   (mkfast
    ;; General
-   ((__init__)    (O 'init))
+   ((__init__)    (O 'py-init))
    ((__getattr__) (O 'getattr))
    ((__setattr__) (O 'setattr))
    ((__delattr__) (O 'delattr))
                (parents (filt parents)))
           `(define ,class
              (,(C 'class-decor) ,decor
-              (,(O kind) 
-               ,class
-               ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
-               #:const
-               ()
-               #:dynamic
-               ,(match (filter-defs (exp vs defs))
-                  (('begin . l)
-                   l)
-                  ((('begin . l))
-                   l)
-                  (l l))))))))))
+              (,(C 'with-class) ,class
+               (,(O kind) 
+                ,class
+                ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
+                #:const
+                ()
+                #:dynamic
+                ,(match (filter-defs (exp vs defs))
+                   (('begin . l)
+                    l)
+                   ((('begin . l))
+                    l)
+                   (l l)))))))))))
 
  (#:scm
   ((_ (#:string _ s)) (with-input-from-string s read)))
                     (,(D 'lam) (,@args ,@*f ,@**f)
                      (,(C 'with-return) ,r
                       ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
-                              ,(with-fluids ((return r))
-                                 (exp ns code)))))))))
+                              (,(C 'with-self) ,c? ,args
+                               ,(with-fluids ((return r))
+                                   (exp ns code))))))))))
                
                `(define ,f
                   (,(C 'def-decor) ,decor
                    (,(D 'lam) (,@args ,@*f ,@**f)
                     (,(C 'with-return) ,r
                      ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
+                             (,(C 'with-self) ,c? ,args
                              ,(with-fluids ((return r))
-                                (exp ns code)))))))))
+                                (exp ns code))))))))))
             
            (if y?
                `(define ,f
                   (,(C 'def-decor) ,decor
                    (,(C 'def-wrap) ,y? ,f ,ab
                     (,(D 'lam) (,@args ,@*f ,@**f)
-                     (,(C 'with-return) ,r
+                     (,(C 'with-return) ,r 
                       (let ,(map (lambda (x) (list x #f)) ls)
-                        ,(with-fluids ((return r))
-                           (mk
-                            (exp ns code)))))))))
+                        (,(C 'with-self) ,c? ,args
+                         ,(with-fluids ((return r))
+                            (mk
+                             (exp ns code))))))))))
                `(define ,f
                   (,(C 'def-decor) ,decor
                    (,(D 'lam) (,@args ,@*f ,@**f)
-                    (,(C 'with-return) ,r
+                    (,(C 'with-return) ,r 
                      (let ,(map (lambda (x) (list x #f)) ls)
-                       ,(with-fluids ((return r))
-                          (exp ns code)))))))))))))
+                       (,(C 'with-self) ,c? ,args
+                        ,(with-fluids ((return r))
+                           (exp ns code))))))))))))))
  
  (#:global
   ((_ . _)
     ((_ () x) x)
     ((_ (f ... r) y)
      (def-decor (f ...) (r y)))))
-
         
+(define-syntax with-self
+  (syntax-rules ()
+    ((_ #f _       c)
+     c)
+    ((_ _  (s . b) c)
+     (syntax-parameterize ((*self* (lambda (x) #'s))) c))))
+
+(define-syntax with-class
+  (syntax-rules ()
+    ((_ s c)
+     (syntax-parameterize ((*class* (lambda (x) #'s))) c))))
index 5b6567b0496077309f504f9abf8e4d67ea095657..f4d13a5d6d50d9a3a9784dd9a194639b2b823ade 100644 (file)
@@ -17,6 +17,8 @@
             py-hash-ref dict pyhash-listing
             ))
 
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
 (define (h x n) (modulo (py-hash x) n))
 
 (define (py-hash-ref . l)
        (define-method (nm (o class) l ...) code ...)
        ...
        (define-method (nm (o   <p>) l ...)
-         ((ref o 'n) l ...))))
+         (aif it (ref o 'n)
+              (it l ...)
+              (next-method)))))
     ((_ (nm n o l ... . u) (class code ...) ...)
      (begin
        (define-method (nm (o class) l ... . u) code ...)
        ...
        (define-method (nm (o   <p>) l ... . u)
-         (apply (ref o 'n) l ... u))))))
-                                      
-                      
+         (aif it (ref o 'n) 
+              (apply it l ... u)
+              (next-method)))))))
+
+
 
 (define-py (py-copy copy o)
   (<hashtable>
 
 (define-python-class dict (<py-hashtable>)
   (define __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))))
-      ((self x)
-       (__init__ self)
-       (if (is-a? x <py-hashtable>)
-           (hash-for-each
-            (lambda (k v)
-              (pylist-set! self k v))
-            (slot-ref x 't)))))))
+    (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))))
+                ((self x)
+                 (__init__ self)
+                 (if (is-a? x <py-hashtable>)
+                     (hash-for-each
+                      (lambda (k v)
+                        (pylist-set! self k v))
+                      (slot-ref x 't)))))))
+      __init__)))
 
 (define (pyhash-listing)
   (let ((l (to-pylist
index 1a3e7c5a69800ed7c0d10764e1ff09ff01e2dd06..5b4daf0f162eb13b45817a7122ac44b2b5939e6c 100644 (file)
@@ -29,7 +29,9 @@
     (pylist-subset! o k (+ k 1) None pylist-null)))
 
 (define-method (pylist-delete! (o <p>) k)
-  ((ref o '__delitem__) k))
+  (aif it (ref o '__delitem__)
+       (it k)
+       (next-method)))
 
 (define pylist-null
   (let ((o (make <py-list>)))
@@ -53,7 +55,9 @@
       x))
 
 (define-method (to-list (x <p>))
-  ((ref x '__tolist__ (lambda () (error "missing __tolist__ in object")))))
+  (aif it (ref x '__tolist__)
+       (it)
+       (next-method)))
 
 
 (define-method (to-list (x <pair>))
   (vector-ref o n))
 
 (define-method (pylist-ref (o <p>) n)
-  ((ref o '__getitem__) n))
+  (aif it (ref o '__getitem__)
+       (it n)
+       (next-method)))
 
 ;;; SET
 (define-method (pylist-set! (o <py-list>) nin val)
   (vector-set! o n val))
 
 (define-method (pylist-set! (o <p>) n val)
-  ((ref o '__setitem__) n val))
+  (aif it (ref o '__setitem__) 
+       (it n val)
+       (next-method)))
 
 ;;SLICE
 (define-method (pylist-slice (o <p>) n1 n2 n3)
-  ((ref o '__getslice__) n1 n2 n3))
+  (aif it (ref o '__getslice__)
+       (it n1 n2 n3)
+       (next-method)))
 
 (define-method (pylist-slice (o <py-list>) n1 n2 n3)
   (define N (slot-ref o 'n))
 
 ;;SUBSET
 (define-method (pylist-subset! (o <p>) n1 n2 n3 val)
-  ((ref o '__setslice__) n1 n2 n3 val))
+  (aif it (ref o '__setslice__)
+       (it n1 n2 n3 val)
+       (next-method)))
 
 (define-method (pylist-subset! (o <py-list>) n1 n2 n3 val)
   (define N (slot-ref o 'n))
 (define-method (pylist-append! (o <p>) n . l)
   (aif it (ref o 'append)
        (apply it n l)
-       (error "no append")))
+       (next-method)))
     
     
 
 
 
 (define-method (pylist-reverse! (o <p>) . l)
-  (apply (ref o 'reverse) l))
+  (aif it (ref o 'reverse) 
+       (apply it l)
+       (next-method)))
 
 ;;POP!
 (define-method (pylist-pop! (o <py-list>))
         (raise IndexError "pop from empty list"))))
 
 (define-method (pylist-pop! (o <p>) . l)
-  (apply (ref o 'pop) l))
+  (aif it (ref o 'pop) 
+       (apply it l)
+       (next-method)))
 
 ;;COUNT
 (define-method (pylist-count (o <py-list>) q)
           sum)))
 
 (define-method (pylist-count (o <p>) . l)
-  (apply (ref o 'count) l))
+  (aif it (ref o 'count) 
+       (apply it l)
+       (next-method)))
 
 ;; extend!
 (define-method (pylist-extend! (o <py-list>) iter)
        (pylist-append! o x)))
 
 (define-method (pylist-extend! (o <p>) . l)
-  (apply (ref o 'extend) l))
+  (aif it (ref o 'extend) 
+       (apply it l)
+       (next-method)))
 
 ;; equal?
 (define-method (equal? (o1 <py-list>) (o2 <py-list>))
               (pylist-append! o v)))
         (raise IndexError "Wrong index in insert"))))
 
-(define-method (pylist-insert! (o <p>) . l) (apply (ref o 'insert) l))
+(define-method (pylist-insert! (o <p>) . l)
+  (aif it (ref o 'insert) 
+       (apply it l)
+       (next-method)))
 
 
 ;;REMOVE
                 (lp (+ i 1))))
           (raise ValueError "list removal has no element to remove")))))
 
-(define-method (pylist-remove! (o <p>) . l) (apply (ref o 'remove) l))
+(define-method (pylist-remove! (o <p>) . l)
+  (aif it (ref o 'remove) 
+       (apply it l)
+       (next-method)))
 
 ;; SORT!
 (define (id x) id)
              (lp (cdr l) (+ i 1))))))
    l))
 
-(define-method (pylist-sort! (o <p>) . l) (apply (ref o 'sort) l))
+(define-method (pylist-sort! (o <p>) . l)
+  (aif it (ref o 'sort) 
+       (apply it l)
+       (next-method)))
 
 ;; INDEX
 (define-method (pylist-index (o <py-list>) val . l)
                   (raise ValueError "could not find value in index fkn")))
             (raise IndexError "index out of scop in index fkn"))))))
                  
-(define-method (pylist-index (o <p>) . l) (apply (ref o 'index) l))
+(define-method (pylist-index (o <p>) . l)
+  (aif it (ref o 'index) 
+       (apply it l)
+       (next-method)))
 
 
 #:len
 (define-method (len (v <vector>))  (vector-length v))
 (define-method (len (s <string>))  (string-length s))
 (define-method (len (o <py-list>)) (slot-ref o 'n))
-(define-method (len (o <p>))       ((ref o '__len__)))
+(define-method (len (o <p>))
+  (aif it (ref o '__len__)
+       (it)
+       (next-method)))
 
 (define-method (in x (l <pair>))   (member x l))
 (define-method (in x (l <vector>))
         #f)))
 
 (define-method (in x (o <p>))
-  ((ref o '__contains__) x))
+  (aif it (ref o '__contains__)
+       (it x)
+       (next-method)))
 
 (define-syntax-rule (defgen (op o1 o2) code ...)
   (begin
     (define-method (op (o1 <py-list>) (o2 <py-list>)) code ...)
     (define-method (op (o1 <pair>)   (o2 <pair>  )) code ...)
-    (define-method (op (o1 <vector>) (o2 <vector>)) code ...)))
+    (define-method (op (o1 <vector>) (o2 <vector>)) code ...)
+    (define-method (op (o1 <p>)      o2)
+      (aif it (ref o1 'r)
+           (it o2)
+           (next-method)))))
 
 (defgen (< o1 o2)
   (let ((n1 (len o1))
           
 (define-python-class list (<py-list>)
   (define  __init__
-    (case-lambda
-      ((self)
-       (slot-set! self 'vec (make-vector 30))
-       (slot-set! self 'n   0))
-      ((self it)
-       (__init__ self)
-       (for ((i : it)) () (pylist-append self i))))))
+    (letrec ((__init__
+              (case-lambda
+                ((self)
+                 (slot-set! self 'vec (make-vector 30))
+                 (slot-set! self 'n   0))
+                ((self it)
+                 (__init__ self)
+                 (for ((i : it)) () (pylist-append! self i))))))
+      __init__)))
 
 (define pylist list)
 
index 1b8973f933003b1015fb506321f6872c7059cf40..4103c4dea2978c0ef08a18524f4a0c2147419b34 100644 (file)
@@ -3,7 +3,8 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 readline)
   #:use-module ((oop pf-objects) #:select
-                (<p> <property> class-method static-method refq))
+                (<p> <property> class-method static-method refq
+                     py-super-mac))
   #:use-module (language python exceptions       )
   #:use-module (language python def              )
   #:use-module (language python for              )
@@ -29,7 +30,7 @@
                   chr classmethod staticmethod
                   divmod enumerate filter format
                   getattr hasattr hash hex isinstance
-                  iter map sum id input oct ord pow))
+                  iter map sum id input oct ord pow super))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
     ((x y z)
      (py-mod (expt x y) z))))
 
-       
+(define-syntax-rule (super . l) (py-super-mac . l))       
 
 (define min  py-min)
 (define max  py-max)
 (define list pylist)
-
index efab4e49e93744eec5e29fa12a3f449921c52cdb..45a3cf4e3b4486028ccf534c9c8a6053a1697800 100644 (file)
@@ -38,7 +38,7 @@
   (begin
     (mk-biop0 op)
     (define-method (op v (o <p>))
-      (aif it (ref o 'r2)
+      (aif it (ref o 'r1)
            (it v)
            (next-method)))))
 
           
 (define-python-class int (<py-int>)
   (define __init__
-    (case-lambda
-      ((self)
-       (__init__ self 0))
-      
-      ((self n)
-       (let lp ((n n))
-         (cond
-          ((and (number? n) (integer? n))
-           (slot-set! self 'x n))
-          ((number? n)
-           (lp (py-floor n)))
-          ((string? n)
-           (lp (string->number n)))
-          (else
-           (aif it (slot-ref n '__int__)
-                (slot-set! self 'x it)
-                (raise ValueError "could not make int from " n))))))
+    (letrec ((__init__
+              (case-lambda
+                ((self)
+                 (__init__ self 0))
+                
+                ((self n)
+                 (let lp ((n n))
+                   (cond
+                    ((and (number? n) (integer? n))
+                     (slot-set! self 'x n))
+                    ((number? n)
+                     (lp (py-floor n)))
+                    ((string? n)
+                     (lp (string->number n)))
+                    (else
+                     (aif it (slot-ref n '__int__)
+                          (slot-set! self 'x it)
+                          (raise ValueError "could not make int from " n))))))
       
-      ((self n k)
-       (__init__ self (string->number n k))))))
+                ((self n k)
+                 (__init__ self (string->number n k))))))
+      __init__)))
 
 (define (proj? x)
   (if (number? x)
index 4b227165282341c9621e4ca6997a628465dcf7c6..6ac8874a27bb896c1a533b9d354126d2a05ff5af 100644 (file)
 (define-class <py-string> () str)
 
 (define-syntax-rule (define-py (f n o . u) code ...)
-    (begin
-      (define-method (f (o <string>)    . u) code ...)
-      (define-method (f (o <py-string>) . l) (apply f (slot-ref o 'str) l))
-      (define-method (f (o <p>)         . l) ((ref o 'n) l))))
+  (begin
+    (define-method (f (o <string>)    . u) code ...)
+    (define-method (f (o <py-string>) . l) (apply f (slot-ref o 'str) l))
+    (define-method (f (o <p>)         . l)
+      (aif it (ref o 'n)
+           (apply it l)
+           (next-method)))))
 
 (define-py (py-capitalize capitalize s)
   (let* ((n (len s))
index 56247abb8865a106905b9e138213fe7ee810b348..950a0ca628c918930d624646a2870c0a722d4def 100644 (file)
@@ -11,6 +11,8 @@
                 def-py-class  mk-py-class  make-py-class
                 define-python-class get-type py-class
                 object-method class-method static-method
+                py-super-mac py-super
+                *class* *self*
                 ))
 #|
 Python object system is basically syntactic suger otop of a hashmap and one
@@ -597,7 +599,7 @@ explicitly tell it to not update etc.
                                    ((ddef dname dval) (... ...)))
     (let ()
       (define name 
-        (let* ((mname sval) (... ...) (dname dval) (... ...))
+        (letruc ((mname sval) (... ...) (dname dval) (... ...))
           (make-pf-class name
                          (let ((s (make-pf)))
                            (set s 'mname mname) (... ...)
@@ -670,32 +672,142 @@ explicitly tell it to not update etc.
 
 (define (pyclass? x)
   (and (is-a? x <p>)
-       (not (ref x '__class__))))
-
+       (if (ref x '__class__)
+         #f
+         (if (ref x '__super__)
+             'super
+             #t))))
 
 (define-method (py-class (o <p>))
   (ref o '__class__ 'type))
 
-(define (mark-fkn f)
-  (set-procedure-property! f 'py-special #t)
+(define (mark-fkn tag f)
+  (set-procedure-property! f 'py-special tag)
   f)
 
 (define (object-method f)
-  (mark-fkn
-   (lambda (x)
-     (if (pyclass? x)
-         f
-         (lambda z (apply f x z))))))
+  (letrec ((self
+            (mark-fkn 'object
+                      (lambda (x)
+                        (aif it (pyclass? x)
+                             (if (eq? it 'super)
+                                 self
+                                 f)
+                             (lambda z (apply f x z)))))))
+    self))
 
 (define (class-method f)
-  (mark-fkn
-   (lambda (x)
-     (if (pyclass? x)
-         (lambda z (apply f x z))
-         (lambda z (apply f (ref x '__class__) z))))))
+  (letrec ((self
+            (mark-fkn 'class
+              (lambda (x)
+                (aif it (pyclass? x)
+                     (if (eq? it 'super)
+                         self
+                         (lambda z (apply f x z)))
+                     (lambda z (apply f (ref x '__class__) z)))))))
+    self))
 
 (define (static-method f)
-  (mark-fkn
-   (lambda (x) f)))
+  (letrec ((self
+            (mark-fkn 'static
+                      (lambda (x)
+                        (if (eq? (pyclass? x) 'super)
+                            self
+                            f)))))
+    self))
 
         
+(define-syntax-parameter
+  *class* (lambda (x) (error "*class* not parameterized")))
+(define-syntax-parameter
+  *self* (lambda (x) (error "*class* not parameterized")))
+
+(define *super* (list 'super))
+
+(define (py-super class obj)
+  (define (make cl parents)
+    (let ((c (make-p))
+          (o (make-p)))
+      (set c '__super__        #t)
+      (set c '__parents__       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 ((c (ref obj '__class__)))
+          (if (eq? class c)
+              (let ((p (ref c '__parents__)))
+                (if (pair? p)
+                    (values (car p) p)
+                    (values #t #t)))
+              (let lp2 ((p (ref c 'parents)))
+                (if (pair? p)
+                    (call-with-values (lambda () (lp (car p)))
+                      (lambda (c ps)
+                        (cond
+                         ((eq? c #t)
+                          (if (pair? p)
+                              (let ((x (car p)))
+                                (values
+                                 x
+                                 (append
+                                  (ref x '__parents__)
+                                  (cdr p))))
+                              (values #t #t)))
+                         (c
+                          (values c (append ps (cdr p))))
+                         (else
+                          (lp2 (cdr p))))))                      
+                    (values #f #f))))))
+    make))
+        
+        
+   
+(define-syntax py-super-mac
+  (syntax-rules ()
+    ((_)
+     (py-super *class* *self*))
+    ((_ class self)
+     (py-super class self))))
+
+(define-syntax letruc
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((x v) ...) code ...)
+       (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
+         (if (pair? a)
+             (let* ((x (car a))
+                    (s (syntax->datum x)))
+               (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
+                         (r (list (car b))))
+                 (if (pair? a2)
+                     (if (eq? (syntax->datum a2) s)
+                         (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
+                         (lp2 (cdr a2) (cdr b2)
+                              (cons (car a2) a3)
+                              (cons (car b2) b3)
+                              r))
+                     (lp (reverse a3) (reverse b3)
+                         (cons
+                          (list x #`(let* #,(map (lambda (v) (list x v))
+                                                 (reverse r)) #,x))
+                          u)))))
+             #`(letrec #,(reverse u) code ...)))))))
+                        
+
+             
+       
+(define-method (py-init (o <p>) . l)
+  (apply (ref o '__init__) l))