blob: a9aa69249344dcd08573786c3467664fd0cb582d (
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
|
(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 ww* kw s v)
(if (null? ww*)
(values ww*
(aif it (hash-ref kw s #f)
(begin
(hash-remove! kw s)
it)
v))
(begin
(hash-remove! kw s)
(values (cdr ww*) (car ww*)))))
(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-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 ww* kw s v))
...)
(let ((ww ww*))
code ...))))))))))))
(define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
|