better procedure management
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 23 Mar 2018 08:10:58 +0000 (09:10 +0100)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 23 Mar 2018 08:10:58 +0000 (09:10 +0100)
modules/language/python/compile.scm
modules/language/python/dict.scm
modules/language/python/dir.scm
modules/language/python/for.scm
modules/language/python/procedure.scm [new file with mode: 0644]

index f97597ca8111c1288b2c9753695f0c9b50689a9d..f936aa0d00638efc3cb2b9d1623902432b8bec81 100644 (file)
@@ -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))
index 58d7cb74bae4ae7f211981f12ad1b8aec0e007ed..5c7eb4a3c11bf6e7b1fde84b06d10001eb2e2252 100644 (file)
                    (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__
                         (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__
                       (slot-ref x 't)))))))
       __init__)))
 
-(name-object weak-value-dict)
-
 (define (pyhash-listing)
   (let ((l (to-pylist
             (map symbol->string
index e41e2357a5f3c354fa7e333ea24687628279a98a..fe7edaeefff0db9ad6638ec8b6cabb7d8a44e701 100644 (file)
       (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))
-
                   
                           
index fcd562bc65be5f515bc2f07784065a389b9b7da2..bf37bad52a013d34b41f5417a59b07740241fa5e 100644 (file)
@@ -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)
                                   (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 (file)
index 0000000..55d0b24
--- /dev/null
@@ -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))