further refinements of properties
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 4 Oct 2017 19:19:09 +0000 (21:19 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 4 Oct 2017 19:19:09 +0000 (21:19 +0200)
modules/language/python/def.scm
modules/language/python/module/python.scm
modules/oop/pf-objects.scm

index c65cd07a818c3bdddf257c0d778252f5973ee8ac..1b91f85f545400c6d08b2fa2e8328f9bc2c094af 100644 (file)
                      (hash-remove! kw s)
                      it)
                    v))
-      (begin
-        (hash-remove! kw s)
-        (values (cdr ww*) (car ww*)))))
+      (if (pair? ww*)
+          (begin
+            (hash-remove! kw s)
+            (values (cdr ww*) (car ww*)))
+          (values ww*
+                  (aif it (hash-ref kw s #f)
+                       (begin
+                         (hash-remove! kw s)
+                         it)
+                       v)))))
+                       
 
 (define (get-akw l)
   (let lp ((l l) (args '()) (kw (make-hash-table)))
index 110ae6b6a113b1a33feabb87c3976138a71024e5..1b8973f933003b1015fb506321f6872c7059cf40 100644 (file)
   #:use-module (language python number           )
   #:use-module (language python dir              )
   #:use-module (language python hash             )
+  #:use-module (language python property         )
 
   #:replace (list abs min max)
   #:re-export (Exception StopIteration send sendException next
                          GeneratorExit sendClose RuntimeError
-                         len dir next dict None)
+                         len dir next dict None property)
   #:export (print repr complex float int round
                   set all any bin callable
                   chr classmethod staticmethod
                   divmod enumerate filter format
                   getattr hasattr hash hex isinstance
-                  iter map sum id input oct ord pow
-                  property))
+                  iter map sum id input oct ord pow))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
     ((x y z)
      (py-mod (expt x y) z))))
 
-(def (property (= getx None) (= setx None) (= delx None))
-     (let ((o (make <property>)))
-       (slot-set! o 'get getx)
-       (slot-set! o 'set setx)
-       (slot-set! o 'del delx)
-       o))
        
 
 (define min  py-min)
index 05f65bef5ea301e06667374d458f6f7e2ac75424..56247abb8865a106905b9e138213fe7ee810b348 100644 (file)
@@ -165,9 +165,10 @@ explicitly tell it to not update etc.
 (define not-implemented (cons 'not 'implemeneted))
 
 (define-syntax-rule (prop-ref xx x)
-    (let ((r x))
-      (if (is-a? r <property>)
-          ((slot-ref r 'get) xx)
+  (let ((y xx)
+        (r x))
+      (if (and (is-a? r <property>) (not (pyclass? y)))
+          ((slot-ref r 'get) y)
           r)))
 
 (define-syntax-rule (mrefx-py- x key l)
@@ -300,7 +301,7 @@ explicitly tell it to not update etc.
 
 (define-syntax-rule (mset-py- x key val)
   (let ((v (mref- x key fail)))
-    (if (or (eq? v fail) (not (is-a? v <property>)))
+    (if (or (eq? v fail) (not (and (is-a? v <property>) (not (pyclass? x)))))
         (let ((f (mref-py- x '__setattr__ '())))
           (if (or (eq? f not-implemented) (not f))
               (mset- x key val)              
@@ -308,7 +309,11 @@ explicitly tell it to not update etc.
         ((slot-ref v 'set) x val))))
 
 (define-syntax-rule (mklam (mset a ...) val)
-  (if (procedure? val)
+  (if (and (procedure? val)
+           (not (pyclass? val))
+           (if (is-a? val <p>)
+               (ref val '__call__)
+               #t))
       (if (procedure-property val 'py-special)
           (mset a ... val)
           (mset a ... (object-method val)))
@@ -592,7 +597,7 @@ explicitly tell it to not update etc.
                                    ((ddef dname dval) (... ...)))
     (let ()
       (define name 
-        (letrec ((mname sval) (... ...) (dname dval) (... ...))
+        (let* ((mname sval) (... ...) (dname dval) (... ...))
           (make-pf-class name
                          (let ((s (make-pf)))
                            (set s 'mname mname) (... ...)