blob: d1a9c15adf2e7d752893ad938a3a2b39b4ef384b (
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
|
(defun sys:vars-check (form vars)
(unless (listp vars)
(compile-error form "~s is expected to be variable binding syntax" vars))
(whenlet ((bad (find-if [notf consp] vars)))
(compile-error form "~s isn't a var-initform pair" bad)))
(defun sys:bindable-check (form syms)
(whenlet ((bad (find-if [notf bindable] syms)))
(compile-error form "~s isn't a bindable symbol" bad)))
(defun sys:expand-each-prod (form vars body)
(sys:vars-check form vars)
(let ((syms [mapcar car vars])
(inits [mapcar cadr vars]))
(sys:bindable-check form syms)
(let ((fun (caseq (car form)
(each-prod 'maprodo)
(collect-each-prod 'maprod)
(append-each-prod 'maprend))))
^(,fun (lambda (,*syms) ,*body) ,*inits))))
(defun sys:expand-each-prod* (form vars body)
(sys:vars-check form vars)
(let* ((each-prod-op (caseq (car form)
(each-prod* 'each-prod)
(collect-each-prod* 'collect-each-prod)
(append-each-prod* 'append-each-prod)))
(syms [mapcar car vars])
(inits [mapcar cadr vars]))
^(let* ,vars
(,each-prod-op ,(zip syms syms) ,*body))))
(defmacro each-prod (:form f vars . body)
(sys:expand-each-prod f vars body))
(defmacro collect-each-prod (:form f vars . body)
(sys:expand-each-prod f vars body))
(defmacro append-each-prod (:form f vars . body)
(sys:expand-each-prod f vars body))
(defmacro each-prod* (:form f vars . body)
(sys:expand-each-prod* f vars body))
(defmacro collect-each-prod* (:form f vars . body)
(sys:expand-each-prod* f vars body))
(defmacro append-each-prod* (:form f vars . body)
(sys:expand-each-prod* f vars body))
|