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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
(in-package :lambda-riffs)
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; some fucntions for workign with substitution variables
(defun substitute-var-p (symbol prefix)
(and (not (eql '$ symbol))
(symbolp symbol)
(<= (length prefix)
(length (symbol-name symbol)))
(string-equal (symbol-name symbol) prefix
:end1 (length prefix))))
(defun numeric-var-p (symbol prefix)
(and (substitute-var-p symbol prefix)
(digit-char-p
(elt (symbol-name symbol) (length prefix)))))
(set-dispatch-macro-character
#\# #\$
(lambda (stream subchar infix)
(declare (ignore subchar infix))
(let ((form1 (read stream)))
(if (symbolp form1)
(list '$ (list (concatenate 'string "$"
(symbol-name form1)))
(read stream))
(list '$ () form1)))))
(set-dispatch-macro-character
#\# #\~
(lambda (stream subchar arg)
(declare (ignore arg subchar))
(list 'make-lazy (read stream))))
(set-dispatch-macro-character
#\# #\!
(lambda (stream subchar arg)
(declare (ignore arg subchar))
(list 'funcall (read stream)))))
;; Note, presently references to upper level variables in nested
;; partials requires tha tthose upper level variables acttually appear
;; in the upper level partials.
;; e.g.
;;
;; #$(mapcar #$$(cons $$x (length $xs)) $xs)
;;
;; is OK but
;;
;; #$(mapcar #$$(cons $$x (length $passed-in-list)) '(1 2 3 4))
;;
;; is not ok.
(defmacro $ ((&optional (prefix "$")) expr)
"Function splicer. A kind of partial evaluation.
Meant to be used in conjunction with the reader macro #$.
E.g.
#$(+ $X 1)
is roughly equivalent to
(LAMBDA ($X) (+ $X 1))
The order of arguments can be controlled by using positional
variables. E.g.
#$(+ $2 $1)
is equivalent to
(LAMBDA ($1 $2) (+ $2 $1))
Limited nestiing is supported. E.g.
#$(MAPCAR #$$(CONS $$INNER (LENGTH $OUTER)) $OUTER)
is equvalent to
(LAMBDA ($OUTER)
(MAPCAR (LAMBDA ($$INNER) (CONS $$INNER (LENGTH $OUTER)))
$OUTER))
However, a variable inside a nested form must actually appear in the
surrounding form.
THIS WONT WORK: #$(+ #$$(* $X $$Y)) because $$Y doesn't appear in the
surrounding form.
"
(let ((new-params (list))
(numeric-params nil))
(labels ((walk (node)
(cond ((and
(consp node)
(consp (car node))
(eq '$ (caar node)))
(walk (cdr node)))
((consp node)
(walk (car node))
(walk (cdr node)))
(t
(when (substitute-var-p node prefix)
(pushnew node new-params))
(when (numeric-var-p node prefix)
(setf numeric-params t))))))
(walk expr))
(setf new-params
(if numeric-params
(sort new-params #'<
:key (lambda (var)
(parse-integer (symbol-name var)
:junk-allowed t
:start (length prefix))))
(reverse new-params)))
`(lambda ,new-params ,expr)))
(defmacro conj (&rest preds)
"A composition macro. Short circuiting predicate conjunction."
(let ((block-label (gensym)))
`(let ((preds (list ,@preds)))
(lambda (arg)
(block ,block-label
(unless preds (return-from ,block-label t))
(let (acc)
(dolist (p preds acc)
(setf acc (funcall p arg))
(unless acc (return-from ,block-label nil)))))))))
(defmacro disj (&rest preds)
"A composition macro. Short circuiting predicate disjunction."
(let ((block-label (gensym)))
`(let ((preds (list ,@preds)))
(lambda (arg)
(block ,block-label
(unless preds (return-from ,block-label nil))
(let (acc)
(dolist (p preds acc)
(setf acc (funcall p arg))
(when acc (return-from ,block-label acc)))))))))
(defmacro make-lazy (form)
"Wraps FORM in a thunk. Intended to be used with teh #~ and #! reader macros:
(let ((computation #~(progn (print 'hey) 10)))
(cons #!computation #!computation))
HEY
(10 . 10)
The first time the computation is forced, it is run, and HEY is
printed. But the next time only the return value is used.
"
(let ((run-p (gensym))
(val (gensym)))
`(let ((,run-p nil)
(,val nil))
(lambda ()
(unless ,run-p
(setf ,val ,form)
(setf ,run-p t))
,val))))
(defmacro binding> ((&key (exit-when #'null) (exit-with #'identity)) init &rest functions)
"A threading macro. Some examples:
(binding> ()
\"hey dude what's the big idea\" ; starting state
#$(values (search \"the\" $s) $s) ; multiple-values are passed along as arguments
#$(subseq $2 $1)) : returns the result of the last form
should return \"the big idea\"
(binding> (:exit-with \"☹\")
\"hey dude what's the big idea?\"
#$(values (search \"NOOOOOOPE\" $s) $s)
#$(subseq $2 $1))
should return \"☹\".
EXIT-WHEN should be a function, a predicate, that operates on the
first value returned from one of the forms. If non-NIL, the BINDING>
form returns by calling the EXIT-WITH function on the list of values
returned the the most recently called function.
e.g
(binding> (:exit-when #'evenp
:exit-with #$(list* :failed $x))
33
#$(+ 11 $x)
#$(- 5 $x))
will return (:FAILED 44)
The default value of EXIT-WHEN is the predicate NULL.
The default value of EXIT-WITH is IDENTITY
"
(let ((vals (gensym))
(fn (gensym))
(block-label (gensym)))
`(let ((,vals (multiple-value-list ,init)))
(block ,block-label
(dolist (,fn (list ,@functions) (values-list ,vals))
(setq ,vals (multiple-value-list (apply ,fn ,vals)))
(when (funcall ,exit-when (car ,vals))
(return-from ,block-label (funcall ,exit-with ,vals))))))))
|
