blob: 1b91f85f545400c6d08b2fa2e8328f9bc2c094af (
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
|
(define-module (language python def)
#:use-module (ice-9 match)
#:use-module (srfi srfi-11)
#:export (def lam))
(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
(define (fold lam s l)
(if (pair? l)
(lam (car l) (fold lam s (cdr l)))
s))
(define-syntax-rule (take-1 pww ww* kw s v)
(if (not pww)
(values ww*
(aif it (hash-ref kw s #f)
(begin
(hash-remove! kw s)
it)
v))
(if (pair? ww*)
(begin
(hash-remove! kw s)
(values (cdr ww*) (car ww*)))
(values ww*
(aif it (hash-ref kw s #f)
(begin
(hash-remove! kw s)
it)
v)))))
(define (get-akw l)
(let lp ((l l) (args '()) (kw (make-hash-table)))
(match l
(((? keyword? k) v . l)
(hash-set! kw k v)
(lp l args kw))
((x . l)
(lp l (cons x args) kw))
(()
(values (reverse args) kw)))))
(define hset! hash-set!)
(define (pytonize kw)
(hash-fold
(lambda (k v h)
(hset! h (symbol->string (keyword->symbol k)) v)
h)
(make-hash-table)
kw))
(define-syntax lam
(lambda (x)
(define-syntax-rule (mk get-as (k v s) x y z w)
(define get-as
(lambda (a s)
(syntax-case a (= * **)
((= k v) x)
((** k) y)
((* k) z)
(k w)))))
(mk get-as (k v s)
s s s (cons #'k s))
(mk get-kw (k v s)
s (cons #'k s) s s )
(mk get-ww (k v s)
s s (cons #'k s) s )
(mk get-kv (k v s)
(cons (cons #'k #'v) s) s s s )
(define (->kw x) (symbol->keyword (syntax->datum x)))
(syntax-case x ()
((_ (arg ...) code ...)
(let* ((as (fold get-as '() #'(arg ...)))
(kw (fold get-kw '() #'(arg ...)))
(ww- (fold get-ww '() #'(arg ...)))
(kv (fold get-kv '() #'(arg ...))))
(if (and-map null? (list kw ww- kv))
#`(lambda #,as code ...)
(with-syntax ((kw (if (null? kw)
(datum->syntax x (gensym "kw"))
(car kw)))
(ww (if (null? ww-)
(datum->syntax x (gensym "ww"))
(car ww-)))
((k ...) (map car kv))
((s ...) (map ->kw (map car kv)))
((v ...) (map cdr kv)))
#`(lambda* (#,@as . l)
(call-with-values (lambda () (get-akw l))
(lambda (ww* kw)
(let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
...)
(let ((ww ww*)
(kw (pytonize kw)))
code ...))))))))))))
(define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
|
