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
|
;;;; hyperquirks.lisp
(in-package #:hyperquirks)
;;; MACROS
(defmacro with-env ((&rest bindings) &body body)
(let ((bindings
(loop :for binding :in bindings
:collect (list* (gensym "VAR") (gensym "VAL") binding))))
`(let* ,(loop :for (oldval cacheval envvar newval) :in bindings
:collect `(,oldval (uiop:getenv ,envvar))
:collect `(,cacheval ,newval))
(setf ,@(loop :for (oldval cacheval envvar newval) :in bindings
:collect `(uiop:getenv ,envvar)
:collect cacheval))
(unwind-protect (progn ,@body)
,@(loop :for (oldval cacheval envvar newval) :in (reverse bindings)
:collect `(when ,oldval
(setf (uiop:getenv ,envvar) ,oldval)))))))
(defmacro let+ (bindings &body body)
"General purpose binding. Normal let bindings, destructuring-binds,
and multiple-value-binds all in the same form.
(let+ ((x
10)
((y z . w)
(list 1 2 3 4 5))
(p q r
(values :oh :my :goodness)))
(list x y x w p q r))
;; returns
(10 1 2 (3 4 5) :oh :my :goodness)
"
(flet ((destructuring-binding-p (binding)
(and (consp (first binding))
(every #'symbolp (first binding))))
(mvb-binding-p (binding)
(and (every #'symbolp (butlast binding))
(consp (first (last binding))))))
(loop
:with body = `(progn ,@body)
:for binding :in (reverse bindings)
:when (destructuring-binding-p binding)
:do (setf body
`(destructuring-bind ,(first binding) ,(second binding)
,body))
:when (mvb-binding-p binding)
:do (setf body
`(multiple-value-bind
,(butlast binding) ,(first (last binding))
,body))
:finally (return body))))
(defmacro imperative (&body body)
"Evaluate expressins in BODY in sequence. Expressions that look
like (:= VAR1 EXPR1 ...) will expand into a LET* form whose bindings
are valid for the rest of the BODY
E.g.
(imperative
(format t \"Welcome to IMPERATIVE\")
(terpri)
(:= x 10 z (+ x 20))
(format t \"X = ~a, Z = ~a~%\" x z)
(:= y (+ z 20))
(format t \"Y = ~a~%\" y)
(list x y z))
would evaluate to:
Welcome to IMPERATIVE ;; <-- printed to stdout
X = 10, Z = 30
Y = 50
(10 50 30) ;; <-- return value
IMPERATIVE introduces an implicit, anonymous BLOCK, and hence can be
returned from.
"
(labels ((binding-form-p (form)
(and (consp form)
(keywordp (first form))
(eql := (first form))))
(collect-bindings (bindings)
(loop for (var expr . more) on bindings by #'cddr
collect (list var expr)))
(expander (body)
(cond
((null body) body)
((binding-form-p (first body))
(list (list* 'let* (collect-bindings (rest (first body)))
(expander (rest body)))))
(t
(cons (first body)
(expander (rest body)))))))
`(block () ,@(expander body))))
(defmacro $> (input-form &rest functions)
(loop :with sub = input-form
:for next-form :in piped-to-forms
:when (symbolp next-form)
:do (setf sub `(funcall ,next-form ,sub))
:when (consp next-form)
:do (setf sub `(,(first next-form) ,sub ,@(rest next-form)))
:finally (return sub )))
(defmacro binding-cond (&body clauses)
"Like cond except the first form of every clause is a binding form
alá IMPERATIVE.
E.g.
(binding-cond
((:= x (and (zerop (random 2)) 10)
y 11)
(list :x x :y y))
(t
12))
That would bind x and y in the first clause, check both both are non
nil, and if they are, return the evaluated body, in this case (list :x x :y y)
Otherwise 12 would be returned."
(let ((imperative-body
(loop for (bindings . body) in clauses
for vars = (unless (eq t bindings)
(loop for (var _ . more) on (rest bindings) by #'cddr
collect var))
collect bindings
collect `(when (and ,@vars) (return (progn ,@body))))))
`(imperative ,@imperative-body)))
(defmacro defun-case (name &rest clauses)
"Clauses look like (VARLIST . BODY)
E.g.
(defun-case foobar
(() 10)
((x y) (+ x y))
((foo) (* foo 2))
((a b c d) (list a b c d)))"
(let* ((rest-args
(gensym "variable-pattern-"))
(clauses
(loop for (arglist . body) in clauses
collect `(,(length arglist)
(destructuring-bind ,arglist ,rest-args
,@body)))))
`(defun ,name (&rest ,rest-args)
(case (length ,rest-args)
,@clauses))))
|
