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
|
(defmacro ifa (:env e :form f test then : else)
(flet ((candidate-p (form)
(not (or (constantp form e) (symbolp form)))))
(cond
((or (atom test) (null (cdr test))) ^(let ((it ,test))
(if it ,then ,else)))
((member (first test) '(not null false))
(unless (eql (length test) 2)
(compile-error f "wrong number of arguments to ~s" (first test)))
^(ifa ,(second test) ,else ,then))
(t (let* ((sym (first test))
(args (if (eq 'dwim sym) (cddr test) (cdr test)))
(n-candidate-args [count-if candidate-p args])
(pos-candidate (or [pos-if candidate-p args] 0)))
(unless (or (lexical-fun-p e sym)
(and (or (functionp (symbol-function sym))
(eq sym 'dwim)
(null (symbol-function sym)))))
(compile-error f "test expression must be \
\ a simple function call"))
(when (> n-candidate-args 1)
(compile-error f "ambiguous situation: \
\ not clear what can be \"it\""))
(iflet ((it-form (macroexpand [args pos-candidate] e))
(is-place (place-form-p it-form e)))
(let ((before-it [args 0..pos-candidate])
(after-it [args (succ pos-candidate)..:]))
(let* ((btemps (mapcar (ret (gensym)) before-it))
(atemps (mapcar (ret (gensym)) after-it)))
^(let (,*(zip btemps before-it))
(placelet ((it (read-once ,it-form)))
(let (,*(zip atemps after-it))
(if (,sym ,*(if (eq 'dwim sym) ^(,(second test)))
,*btemps it ,*atemps)
,then ,else))))))
(let* ((temps (mapcar (ret (gensym)) args))
(it-temp [temps pos-candidate]))
^(let* (,*(zip temps args) (it ,it-temp))
(if (,sym ,*(if (eq 'dwim sym) ^(,(second test)))
,*temps) ,then ,else)))))))))
(defmacro whena (test . body)
^(ifa ,test (progn ,*body)))
(defun sys:if-to-cond (f if-oper pairs)
(with-gensyms (res)
^(let (,res)
(or ,*(collect-each ((c pairs))
(mac-param-bind f (test . forms) c
^(,if-oper ,test (progn (set ,res (progn ,*forms)) t)))))
,res)))
(defmacro conda (:form f . pairs)
(sys:if-to-cond f 'ifa pairs))
(defmacro condlet (:form f . pairs)
(sys:if-to-cond f 'iflet pairs))
|