better procedure management

5 files changed, 136 insertions, 21 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index f97597c..f936aa0 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -15,6 +15,8 @@
   #:use-module (language python number)
   #:use-module (language python def)
   #:use-module (language python module)
+  #:use-module (language python dir)
+  #:use-module (language python procedure)
   #:use-module ((language python with) #:select ())
   #:use-module (ice-9 pretty-print)
   #:export (comp))
diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm
index 58d7cb7..5c7eb4a 100644
--- a/modules/language/python/dict.scm
+++ b/modules/language/python/dict.scm
@@ -543,13 +543,9 @@
                    (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)))))))
+		 (for ((k v : x)) ()
+		      (pylist-set! self k v))))))
       __init__)))
-(name-object dict)
 
 (define-python-class weak-key-dict (<py-hashtable>)
   (define __init__
@@ -568,7 +564,6 @@
                         (pylist-set! self k v))
                       (slot-ref x 't)))))))
       __init__)))
-(name-object weak-key-dict)
 
 (define-python-class weak-value-dict (<py-hashtable>)
   (define __init__
@@ -588,8 +583,6 @@
                       (slot-ref x 't)))))))
       __init__)))
 
-(name-object weak-value-dict)
-
 (define (pyhash-listing)
   (let ((l (to-pylist
             (map symbol->string
diff --git a/modules/language/python/dir.scm b/modules/language/python/dir.scm
index e41e235..fe7edae 100644
--- a/modules/language/python/dir.scm
+++ b/modules/language/python/dir.scm
@@ -150,15 +150,5 @@
       (pylist-sort! ret)
       ret)))
 
-(define-method (dir (o <procedure>))
-  (let ((ret (to-pylist (map (lambda (x)
-                               (let ((x (car x)))
-                                 (if (symbol? x)
-                                     (symbol->string x)
-                                     x)))
-                             (procedure-properties o)))))
-    (pylist-sort! ret)
-    ret))
-
                   
                           
diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm
index fcd562b..bf37bad 100644
--- a/modules/language/python/for.scm
+++ b/modules/language/python/for.scm
@@ -2,6 +2,7 @@
   #:use-module (language python yield)
   #:use-module (oop pf-objects)
   #:use-module (language python exceptions)
+  #:use-module (language python def)
   #:use-module (oop goops)
   #:use-module (ice-9 control)
   #:use-module (language python persist)
@@ -78,8 +79,12 @@
                                   (set! x1 x2) ...)))
                            (if (> N 1)
                                (case-lambda
-                                 ((q)
-                                  (apply f q))
+				((q)
+				 (if (pair? q)
+				     (if (pair? (cdr q))
+					 (apply f q)
+					 (apply f (car q) (cdr q)))
+				     (py-apply f (* q))))
                                  (q
                                   (apply f q)))
                                (lambda (x2 ... . ll)
diff --git a/modules/language/python/procedure.scm b/modules/language/python/procedure.scm
new file mode 100644
index 0000000..55d0b24
--- /dev/null
+++ b/modules/language/python/procedure.scm
@@ -0,0 +1,125 @@
+(define-module (language python procedure)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (language python dir)
+  #:use-module (language python try)
+  #:use-module (language python def)
+  #:use-module (language python list)
+  #:use-module (language python for)
+  #:use-module (language python exceptions)
+  #:use-module (language python dict)
+  #:export (function))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define-python-class function ()
+  (define __init__
+    (lambda x (error "function objects not implemented")))
+
+  (define __call__
+    (lam ((* l) (** kw))
+	 (py-apply (* l) (** kw)))))
+
+(define e (list 'e))
+  
+(define-method (ref (f <procedure>) tag . l)
+  (apply ref-f f tag l))
+
+(define-method (rawref (f <procedure>) tag . l)
+  (apply ref-f f tag l))
+
+(define (ref-f f tag . l)    
+  (set! tag (if (symbol? tag) tag (string->symbol tag)))
+  
+  (cond
+   ((equal? tag '__class__)
+    function)
+   
+   ((equal? tag '__name__)
+    (procedure-name f))
+
+   ((equal? tag '__qualname__)
+    (aif it (procedure-property f '__qualname__)
+	 it
+	 (procedure-name f)))
+
+   ((equal? tag '__dict__)
+    (dict (let lp ((l (procedure-properties f)))
+	    (if (pair? l)
+		(cons (list (car l) (cdr l))
+		      (lp (cdr l)))
+		'()))))
+   
+   ((equal? tag '__annotations__)
+    (procedure-property f '__annotations__))
+
+   ((equal? tag '__closure__)
+    (error "closure property is not implemented"))
+
+   ((equal? tag  '__code__)
+    (error "code tag is not implemented"))
+
+   ((equal? tag '__defaults)
+    (error "defaults tag is not implemented"))
+   
+   ((equal? tag '__kwdefaults__)
+    (error "kwdefaults tag is not implemented"))
+   
+   (else
+    (let ((r (procedure-property f tag)))
+      (if (not r)
+	  (if (pair? l) (car l) #f)
+	  r)))))
+
+(define fixed '(__class__
+		__call__
+		__get__
+		__annotations__
+		__closure__
+		__dict__
+		__globals__
+		__defaults__
+		__kwdefaults__))
+
+(define fixed-str (map symbol->string fixed))
+
+(define-method (set (x <procedure>)  key val)
+  (set-f x key val))
+
+(define-method (rawset (x <procedure>)  key val)
+  (set-f x key val))
+
+(define-method (py-class (o <procedure>))
+  (ref o '__class__))
+
+(define (set-f f tag val)
+  (set! tag (if (symbol? tag) tag (string->symbol tag)))  
+
+  (cond
+   ((equal? tag '__name__)
+    (set-procedure-property! f 'name
+			     (if (symbol? val)
+				 val
+				 (string->symbol val))))
+   ((equal? tag '__dict__)
+    (set-procedure-properties! f
+			       (for ((k v : val)) ((l '()))
+				    (cons (cons k v) l)
+				    #:final
+				    (reverse l))))
+   ((member tag fixed)
+    (raise KeyError (format #f "key ~a is unmutable" tag)))
+   (else
+    (set-procedure-property! f tag val))))
+
+(define-method (dir (o <procedure>))
+  (let ((ret (+ (to-pylist '("__name__" "__qualname__"))
+		(to-pylist fixed-str)		
+		(to-pylist (map (lambda (x)
+				  (let ((x (car x)))
+				    (if (symbol? x)
+					(symbol->string x)
+					x)))
+				(procedure-properties o))))))
+    (pylist-sort! ret)
+    ret))