blob: 1289aaeb95ee36a22f0619366ce13eb202625f60 (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
(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))))
(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))
|
