decorators works

5 files changed, 170 insertions, 51 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 5d9828b..275c635 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -498,14 +498,31 @@
                  ,(if op
                       `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
                       u))))))))
-  
+
+(define (filter-defs x)
+  (match (let lp ((x x))
+           (match x
+             ((('begin . l))
+              (lp (cons 'begin l)))
+             (('begin . l)
+              (let lp ((l l))
+                (match l
+                  ((('values) . l)
+                   (lp l))
+                  ((x . l)
+                   (cons x (lp l)))
+                  (x x))))))
+    (('begin)
+     '())
+    (x x)))
+                  
 (define is-class? (make-fluid #f))
 (define (gen-yargs vs x)
   (match (pr 'yarg x)    ((#:list args)
      (map (g vs exp) args))))
 
 (define inhibit-finally #f)
-
+(define decorations (make-fluid '()))
 (define tagis (make-hash-table))
 (define-syntax-rule (gen-table x vs (tag code ...) ...)
   (begin
@@ -548,6 +565,11 @@
   ((#:identifier x . _)
    (string->symbol x)))
 
+ (#:decorated
+  ((_ (l ...))
+   (fluid-set! decorations (map (g vs exp) l))
+   '(values)))
+ 
  (#:string
   ((#:string #f x)
    x))
@@ -675,9 +697,11 @@
                         ('fast #t)
                         (_ #f))))
                 #f l))
-        
          
-        (let* ((class   (string->symbol class))
+        (let* ((decor   (let ((r (fluid-ref decorations)))
+                          (fluid-set! decorations '())
+                          r))
+               (class   (string->symbol class))
                (parents (match parents
                           (()
                            '())
@@ -695,18 +719,20 @@
                                 'mk-p-class
                                 'mk-py-class)))              
                (parents (filt parents)))
-          `(define ,class (,(O kind) 
-                           ,class
-                           ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
-                           #:const
-                           ()
-                           #:dynamic
-                           ,(match (exp vs defs)
-                              (('begin . l)
-                               l)
-                              ((('begin . l))
-                               l)
-                              (l l)))))))))
+          `(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))))))))))
 
  (#:scm
   ((_ (#:string _ s)) (with-input-from-string s read)))
@@ -890,7 +916,10 @@
        *e **e)
       #f
       code)
-   (let* ((args (get-kwarg-def vs args))
+   (let* ((decor   (let ((r (fluid-ref decorations)))
+                          (fluid-set! decorations '())
+                          r))
+          (args (get-kwarg-def vs args))
           (c?   (fluid-ref is-class?))
           (f    (exp vs f))
           (y?   (is-yield f #f code))
@@ -933,34 +962,39 @@
        (if c?
            (if y?
                `(define ,f
-                  (,(C 'def-wrap) ,y? ,f ,ab
+                  (,(C 'def-decor) ,decor
+                   (,(C 'def-wrap) ,y? ,f ,ab
+                    (,(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)))))))))
+               
+               `(define ,f
+                  (,(C 'def-decor) ,decor
                    (,(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))))))))
-               
-               `(define ,f (,(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))))))))
+                                (exp ns code)))))))))
             
            (if y?
                `(define ,f
-                  (,(C 'def-wrap) ,y? ,f ,ab
+                  (,(C 'def-decor) ,decor
+                   (,(C 'def-wrap) ,y? ,f ,ab
+                    (,(D 'lam) (,@args ,@*f ,@**f)
+                     (,(C 'with-return) ,r
+                      (let ,(map (lambda (x) (list x #f)) ls)
+                        ,(with-fluids ((return r))
+                           (mk
+                            (exp ns code)))))))))
+               `(define ,f
+                  (,(C 'def-decor) ,decor
                    (,(D 'lam) (,@args ,@*f ,@**f)
                     (,(C 'with-return) ,r
                      (let ,(map (lambda (x) (list x #f)) ls)
                        ,(with-fluids ((return r))
-                          (mk
-                           (exp ns code))))))))
-               `(define ,f
-                  (,(D 'lam) (,@args ,@*f ,@**f)
-                   (,(C 'with-return) ,r
-                    (let ,(map (lambda (x) (list x #f)) ls)
-                      ,(with-fluids ((return r))
-                         (exp ns code))))))))))))
+                          (exp ns code)))))))))))))
  
  (#:global
   ((_ . _)
@@ -1595,9 +1629,9 @@
     ((_ v (#:fast-id f _) . l)
      (ref-x (f v) . l))
     ((_ v (#:identifier x) . l)
-     (ref-x (refq v 'x) . l))
+     (ref-x (refq v x) . l))
     ((_ v (#:identifier x) . l)
-     (ref-x (refq v 'x) . l))
+     (ref-x (refq v x) . l))
     ((_ v (#:call-obj x) . l)
      (ref-x (x v) . l))
     ((_ v (#:call x ...) . l)
@@ -1644,3 +1678,17 @@
     ((_ v (#:vecsub x ...) val)
      (pylist-subset! v x ... val))))
 
+
+(define-syntax class-decor
+  (syntax-rules ()
+    ((_ () x) x)
+    ((_ (f ... r) y)
+     (class-decor (f ...) (r y)))))
+
+(define-syntax def-decor
+  (syntax-rules ()
+    ((_ () x) x)
+    ((_ (f ... r) y)
+     (def-decor (f ...) (r y)))))
+
+        
diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm
index 1afa56f..7f0d7e4 100644
--- a/modules/language/python/list.scm
+++ b/modules/language/python/list.scm
@@ -8,13 +8,14 @@
   #:use-module (language python for)
   #:use-module (language python try)
   #:use-module (language python exceptions)
-  #:export (to-list to-pylist <py-list>
+  #:export (to-list to-pylist <py-list> 
             pylist-ref pylist-set! pylist-append!
             pylist-slice pylist-subset! pylist-reverse!
             pylist-pop! pylist-count pylist-extend! len in
             pylist-insert! pylist-remove! pylist-sort!
             pylist-index pylist-null pylist-delete!
-            pylist pylist-listing))
+            pylist pylist-listing
+            py-all py-any))
 
 (define scm-list list)
 
@@ -733,3 +734,20 @@
     
     (pylist-sort! l)
     l))
+
+(define (py-all x)
+  (for ((i : x)) ()
+       (if (not i)
+           (break #f))
+       #:final
+       #t))
+
+(define (py-any x)
+  (for ((i : x)) ()
+       (if i
+           (break #t))
+       #:final
+       #f))
+           
+
+        
diff --git a/modules/language/python/number.scm b/modules/language/python/number.scm
index f2c0c6b..56a50cf 100644
--- a/modules/language/python/number.scm
+++ b/modules/language/python/number.scm
@@ -6,12 +6,12 @@
   #:use-module (language python try)
   #:use-module (language python exceptions)
   #:export (py-int py-float py-complex
-                   py-/ py-logand py-logior py-logxor py-abs
-                   py-lshift py-rshift py-mod py-floordiv
+                   py-/ py-logand py-logior py-logxor py-abs py-trunc
+                   py-lshift py-rshift py-mod py-floordiv py-round
                    <py-int> <py-float> <py-complex>
                    py-divmod pyfloat-listing pyint-listing pycomplex-listing
                    py-as-integer-ratio py-conjugate py-fromhex py-hex py-imag
-                   py-is-integer py-real hex))
+                   py-is-integer py-real hex py-bin))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
@@ -121,11 +121,10 @@
 (mk-biop2 i0 py-rmod py-mod __mod__ __rmod__)
 
 
-(define-method (py-abs (o <number>)) (abs o))
 (define-method (py-floor (o1 <integer>)) o1)
 (define-method (py-floor (o1 <number> )) )
-(define-method (py-float (o1 <integer>)) (exact->inexact o1))
-(define-method (py-float (o1 <number> )) o1)
+(define-method (py-trunc (o1 <integer>)) (exact->inexact o1))
+(define-method (py-trunc (o1 <number> )) o1)
 
 (define-syntax-rule (u0 f)
   (begin
@@ -145,8 +144,7 @@
 
 (u0 py-hash )
 (mk-unop u0 -         __neg__   )
-(mk-unop u0 py-abs    __abs__   )
-(mk-unop u0 py-floor  __floor__ )
+(mk-unop u0 py-trunc  __trunc__ )
 (mk-unop i0 py-lognot __invert__)
 
 (define-method (py-bit-length (i <integer>))
@@ -189,6 +187,12 @@
 (define-method (hex (o <integer>))
   (+ "0x" (number->string o 16)))
 
+(define-method (py-abs (o <complex>))
+  (magnitude o))
+(define-method (py-abs (o <number>))
+  (abs o))
+
+(mk-unop u0 py-abs       __abs__)
 (mk-unop u0 py-conjugate conjugate)
 (mk-unop u0 py-imag imag)
 (mk-unop u0 py-real real)
@@ -363,3 +367,20 @@
                          conjugate imag real)))))
     (pylist-sort! l)
     l))
+
+(define* (py-round x #:optional (digits 0))
+  (let* ((f (expt 1.0 digits))
+         (a (if (< x 0) -0.5 0.5))
+         (x (py-trunc (+ a (* x f)))))
+    (/ x f)))
+         
+(define-method (py-bin (o <integer>))
+  (number->string o 2))
+(define-method (py-bin (o <py-int>))
+  (number->string (slot-ref o 'x) 2))
+(define-method (py-bin (o <p>))
+  (let ((r (ref o '__index__)))
+    (number->string (r) 2)
+    (raise TypeError "object cannot be interpretted as an index")))
+
+  
diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm
index 3164c8f..cd12586 100644
--- a/modules/language/python/set.scm
+++ b/modules/language/python/set.scm
@@ -7,7 +7,7 @@
   #:use-module (language python try)
   #:use-module (language python list)
   #:use-module (language python yield)
-  #:export(set))
+  #:export(py-set))
 
 (define-class <set> () dict)
 
@@ -211,3 +211,5 @@
           (for ((k v : (slot-ref self 'dict))) ()
                (yield k)
                (values))))))
+
+(define py-set set)
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 5937d37..d916fe8 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -10,6 +10,7 @@
                 def-pyf-class mk-pyf-class make-pyf-class
                 def-py-class  mk-py-class  make-py-class
                 define-python-class get-type py-class
+                object-method class-method static-method
                 ))
 #|
 Python object system is basically syntactic suger otop of a hashmap and one
@@ -178,8 +179,7 @@ explicitly tell it to not update etc.
     (let ((xx x))
       (let ((res (mrefx- xx key l)))
         (if (and (not (struct? res)) (procedure? res))
-            (lambda z
-              (apply res xx z))
+            (res xx)
             res)))))
 
 (unx mrefx-    mref-)
@@ -194,8 +194,7 @@ explicitly tell it to not update etc.
         (if (and (not (struct? res))
                  (not (pyclass? res))
                  (procedure? res))
-            (lambda z
-              (apply res xx z))
+            (res xx)
             res)))))
 
 (unx mrefx-    mref-q)
@@ -291,6 +290,13 @@ explicitly tell it to not update etc.
         (mset- x key val)
         (f key val))))
 
+(define-syntax-rule (mklam (mset a ...) val)
+  (if (procedure? val)
+      (if (procedure-property val 'py-special)
+          (mset a ... val)
+          (mset a ... (object-method val)))
+      (mset a ... val)))
+
 (define-method (set (x <pf>)  key val) (mset     x key val))
 (define-method (set (x <p>)   key val) (mset-    x key val))
 (define-method (set (x <pyf>) key val) (mset-py  x key val))
@@ -647,3 +653,27 @@ explicitly tell it to not update etc.
 
 (define-method (py-class (o <p>))
   (ref o '__class__ 'type))
+
+(define (mark-fkn f)
+  (set-procedure-property! f 'py-special #t)
+  f)
+
+(define (object-method f)
+  (mark-fkn
+   (lambda (x)
+     (if (pyclass? x)
+         f
+         (lambda z (apply f x z))))))
+
+(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))))))
+
+(define (static-method f)
+  (mark-fkn
+   (lambda (x) f)))
+
+