better procedure management

1 files changed, 125 insertions, 0 deletions

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))