progressively imporoving the conformance with python3
[software/python-on-guile.git] / modules / language / python / def.scm
1 (define-module (language python def)
2 #:use-module (oop pf-objects)
3 #:use-module (language python for)
4 #:use-module (ice-9 match)
5 #:use-module (srfi srfi-11)
6 #:export (def lam py-apply))
7
8 (define e (list 'error))
9 (define-syntax-rule (aif it p x y) (let ((it p)) (if (not (eq? it e)) x y)))
10 (define (fold lam s l)
11 (if (pair? l)
12 (lam (car l) (fold lam s (cdr l)))
13 s))
14
15 (define-syntax-rule (take-1 pww ww* kw s v)
16 (if (not pww)
17 (values ww*
18 (aif it (hash-ref kw s e)
19 (begin
20 (hash-remove! kw s)
21 it)
22 v))
23 (if (pair? ww*)
24 (begin
25 (hash-remove! kw s)
26 (values (cdr ww*) (car ww*)))
27 (values ww*
28 (aif it (hash-ref kw s e)
29 (begin
30 (hash-remove! kw s)
31 it)
32 v)))))
33
34
35 (define (get-akw l)
36 (let lp ((l l) (args '()) (kw (make-hash-table)))
37 (match l
38 (((? keyword? k) v . l)
39 (hash-set! kw k v)
40 (lp l args kw))
41 ((x . l)
42 (lp l (cons x args) kw))
43 (()
44 (values (reverse args) kw)))))
45
46 (define hset! hash-set!)
47
48 (define (pytonize kw)
49 (hash-fold
50 (lambda (k v h)
51 (hset! h (symbol->string (keyword->symbol k)) v)
52 h)
53 (make-hash-table)
54 kw))
55
56 (define-syntax lam
57 (lambda (x)
58 (define-syntax-rule (mk get-as (k v s) x y z w)
59 (define get-as
60 (lambda (a s)
61 (syntax-case a (= * **)
62 ((= k v) x)
63 ((** k) y)
64 ((* k) z)
65 (k w)))))
66
67 (mk get-as (k v s)
68 s s s (cons #'k s))
69 (mk get-kw (k v s)
70 s (cons #'k s) s s )
71 (mk get-ww (k v s)
72 s s (cons #'k s) s )
73 (mk get-kv (k v s)
74 (cons (cons #'k #'v) s) s s s )
75
76 (define (->kw x) (symbol->keyword (syntax->datum x)))
77
78 (syntax-case x ()
79 ((_ (arg ...) code ...)
80 (let* ((as (fold get-as '() #'(arg ...)))
81 (kw (fold get-kw '() #'(arg ...)))
82 (ww- (fold get-ww '() #'(arg ...)))
83 (kv (fold get-kv '() #'(arg ...))))
84 (if (and-map null? (list kw ww- kv))
85 #`(object-method
86 (lambda (#,@as . u12345678)
87 (if (and (pair? u12345678)
88 (not (keyword? (car u12345678))))
89 (raise (ArgumentError "too many arguments to function")))
90 code ...))
91 (with-syntax ((kw (if (null? kw)
92 (datum->syntax x (gensym "kw"))
93 (car kw)))
94 (ww (if (null? ww-)
95 (datum->syntax x (gensym "ww"))
96 (car ww-)))
97 ((k ...) (map car kv))
98 ((s ...) (map ->kw (map car kv)))
99 ((v ...) (map cdr kv)))
100 #`(object-method
101 (lambda* (#,@as . l)
102 (call-with-values (lambda () (get-akw l))
103 (lambda (ww* kw)
104 (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
105 ...)
106 (let ((ww ww*)
107 (kw (pytonize kw)))
108 code ...)))))))))))))
109
110 (define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
111
112
113 (define (no x)
114 (and-map
115 (lambda (x)
116 (syntax-case x (* ** =)
117 ((* _) #f)
118 ((** _) #f)
119 ((= a b) #f)
120 (_ #t)))
121 x))
122
123 (define (mk-k x)
124 (if (keyword? x)
125 x
126 (symbol->keyword
127 (if (string? x)
128 (string->symbol x)
129 x))))
130
131 (define-syntax m*
132 (syntax-rules (* ** =)
133 ((_ (= a b))
134 (list (symbol->keyword 'a) b))
135 ((_ (* a)) a)
136 ((_ (** kw))
137 (for ((k v : kw)) ((l '()))
138 (cons* v (mk-k k) l)
139 #:final (reverse l)))
140 ((_ a) (list a))))
141
142 (define-syntax py-apply
143 (lambda (x)
144 (syntax-case x ()
145 ((_ f a ...)
146 (if (no #'(a ...))
147 #'(f a ...)
148 #'(apply f (let lp ((l (list (m* a) ...)))
149 (if (pair? l)
150 (append (car l) (lp (cdr l)))
151 '()))))))))
152