better procedure management
[software/python-on-guile.git] / modules / language / python / procedure.scm
1 (define-module (language python procedure)
2 #:use-module (oop pf-objects)
3 #:use-module (oop goops)
4 #:use-module (language python dir)
5 #:use-module (language python try)
6 #:use-module (language python def)
7 #:use-module (language python list)
8 #:use-module (language python for)
9 #:use-module (language python exceptions)
10 #:use-module (language python dict)
11 #:export (function))
12
13 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
14
15 (define-python-class function ()
16 (define __init__
17 (lambda x (error "function objects not implemented")))
18
19 (define __call__
20 (lam ((* l) (** kw))
21 (py-apply (* l) (** kw)))))
22
23 (define e (list 'e))
24
25 (define-method (ref (f <procedure>) tag . l)
26 (apply ref-f f tag l))
27
28 (define-method (rawref (f <procedure>) tag . l)
29 (apply ref-f f tag l))
30
31 (define (ref-f f tag . l)
32 (set! tag (if (symbol? tag) tag (string->symbol tag)))
33
34 (cond
35 ((equal? tag '__class__)
36 function)
37
38 ((equal? tag '__name__)
39 (procedure-name f))
40
41 ((equal? tag '__qualname__)
42 (aif it (procedure-property f '__qualname__)
43 it
44 (procedure-name f)))
45
46 ((equal? tag '__dict__)
47 (dict (let lp ((l (procedure-properties f)))
48 (if (pair? l)
49 (cons (list (car l) (cdr l))
50 (lp (cdr l)))
51 '()))))
52
53 ((equal? tag '__annotations__)
54 (procedure-property f '__annotations__))
55
56 ((equal? tag '__closure__)
57 (error "closure property is not implemented"))
58
59 ((equal? tag '__code__)
60 (error "code tag is not implemented"))
61
62 ((equal? tag '__defaults)
63 (error "defaults tag is not implemented"))
64
65 ((equal? tag '__kwdefaults__)
66 (error "kwdefaults tag is not implemented"))
67
68 (else
69 (let ((r (procedure-property f tag)))
70 (if (not r)
71 (if (pair? l) (car l) #f)
72 r)))))
73
74 (define fixed '(__class__
75 __call__
76 __get__
77 __annotations__
78 __closure__
79 __dict__
80 __globals__
81 __defaults__
82 __kwdefaults__))
83
84 (define fixed-str (map symbol->string fixed))
85
86 (define-method (set (x <procedure>) key val)
87 (set-f x key val))
88
89 (define-method (rawset (x <procedure>) key val)
90 (set-f x key val))
91
92 (define-method (py-class (o <procedure>))
93 (ref o '__class__))
94
95 (define (set-f f tag val)
96 (set! tag (if (symbol? tag) tag (string->symbol tag)))
97
98 (cond
99 ((equal? tag '__name__)
100 (set-procedure-property! f 'name
101 (if (symbol? val)
102 val
103 (string->symbol val))))
104 ((equal? tag '__dict__)
105 (set-procedure-properties! f
106 (for ((k v : val)) ((l '()))
107 (cons (cons k v) l)
108 #:final
109 (reverse l))))
110 ((member tag fixed)
111 (raise KeyError (format #f "key ~a is unmutable" tag)))
112 (else
113 (set-procedure-property! f tag val))))
114
115 (define-method (dir (o <procedure>))
116 (let ((ret (+ (to-pylist '("__name__" "__qualname__"))
117 (to-pylist fixed-str)
118 (to-pylist (map (lambda (x)
119 (let ((x (car x)))
120 (if (symbol? x)
121 (symbol->string x)
122 x)))
123 (procedure-properties o))))))
124 (pylist-sort! ret)
125 ret))