Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 241 lines (195 sloc) 7.047 kb
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;;;; My ``On Lisp'' based tool box ;;;;
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
5 ;;;;;;;;;;;;;;;;;;;;;;
6 ;;;; Utility functions
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
7
8 (in-package :toolbox)
9
0725eb6 @smithzvk Well, a ton of various changes because I haven't made a commit in a
authored
10 (defmacro t-ret (&body body)
11 "A macro that will change the success value of a predicate to an
12 arbitrary value of your choosing. This is helpful for pedicates
13 that return t and not something more useful, making them annoying
14 to use, expecially with anaphoric macros."
15 (let ((ret-sym (gensym "T-RET-")))
16 (multiple-value-bind (new-body ret-val)
17 (extract-ret-call body ret-sym)
18 (if ret-val
19 `(let ((,ret-sym ,ret-val))
20 (if ,@new-body ,ret-sym) )
21 ;; No :ret symbol found, pretend t-ret wasn't used
22 `(progn ,@new-body) ))))
23
24 (defun extract-ret-call (tree ret-val)
25 (cond ((atom tree) (values tree nil))
26 ((eql (car tree) 't-ret) (extract-ret-call (macroexpand tree) ret-val))
27 ((eql (car tree) :ret) (values ret-val (cadr tree)))
28 (t (multiple-value-bind (body1 val1) (extract-ret-call (car tree) ret-val)
29 (multiple-value-bind (body2 val2) (extract-ret-call (cdr tree) ret-val)
30 (values (cons body1 body2) (or val1 val2)) )))))
31
32 ;; Examples
33
34 ;; (extract-ret-call '(> (+ 3 (:ret (+ 2 5))) 4) (gensym))
35
36 ;; (macroexpand-1 '(t-ret (> (+ 3 (:ret (+ 2 3))) 2)))
37
38 ;; (aif (t-ret (> (+ 3 (:ret (+ 2 3))) 2))
39 ;; (- it 5)
40 ;; nil )
41
42 ;; (t-ret (:ret (read)))
43
44 ;; (let ((seq1 '(1 2 3 4))
45 ;; (seq2 '(1 2 3))
46 ;; (seq3 '(5 4 3)) )
47 ;; (aif (t-ret (> (:ret (length seq1)) (length seq2)))
48 ;; (if (> it (length seq3))
49 ;; (aif (t-ret (not (= 0 (:ret (car (last seq1))))))
50 ;; it ))))
51
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
52 ;;;;;;;;;;;;;;;;;;;;;
53 ;;;; Anaphoric macros
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
54
55 (defmacro awhile (expr &body body)
56 `(do ((it ,expr ,expr))
57 ((not it))
58 ,@body ))
59
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
60 ;; (defmacro aif (test-form then-form &optional else-form)
0725eb6 @smithzvk Well, a ton of various changes because I haven't made a commit in a
authored
61 ;; `(anaphora:aif (t-ret ,test-form) ,then-form ,else-form) )
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
62
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
63 ;; (defmacro awhen (test-form &body body)
0725eb6 @smithzvk Well, a ton of various changes because I haven't made a commit in a
authored
64 ;; `(anaphora:awhen (t-ret ,test-form) ,@body) )
65 ;; (defmacro awhen (test-form &body body)
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
66 ;; `(aif ,test-form
67 ;; (progn ,@body) ))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
68
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
69 ;; (defmacro aand (&rest args)
70 ;; (cond ((null args) t)
71 ;; ((null (cdr args)) (car args))
72 ;; (t `(aif ,(car args) (aand ,@(cdr args)))) ))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
73
0725eb6 @smithzvk Well, a ton of various changes because I haven't made a commit in a
authored
74 ;; (defmacro acond (&rest clauses)
75 ;; (let ((new-clauses (mapcar (lambda (x) `((t-ret ,(car x)) ,@(cdr x))) clauses)))
76 ;; `(anaphora:acond ,@new-clauses)) )
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
77 ;; (defmacro acond (&rest clauses)
78 ;; (if (null clauses)
79 ;; nil
80 ;; (let ((cl1 (car clauses))
81 ;; (sym (gensym "ACOND-")) )
82 ;; `(let ((,sym ,(car cl1)) )
83 ;; (if ,sym
84 ;; (let ((it ,sym)) ,@(cdr cl1))
85 ;; (acond ,@(cdr clauses)) )))))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
86
87 (defmacro alambda (parms &body body)
88 `(labels ((self ,parms ,@body))
89 #'self ))
90
91 (defmacro ablock (tag &rest args)
92 `(block ,tag
93 ,(funcall (alambda (args)
94 (case (length args)
95 (0 nil)
96 (1 (car args))
97 (t `(let ((it ,(car args)))
98 ,(self (cdr args)) ))))
99 args )))
100
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
101 ;; ;; Examples
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
102
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
103 ;; (macroexpand-1
104 ;; '(aif (member 1 '(2 3 1 4 5))
105 ;; (reverse it) ))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
106
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
107 ;; (aand (member 3 '(1 2 3 4 5)) (reverse it))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
108
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
109 ;; (let ((var 99))
110 ;; (acond ((member var '(4 3 1 2 3)) (reverse it))
111 ;; ((find-if #'evenp '(3 5 7 2)) (print (- it 5)))
112 ;; (t 'otherwise) ))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
113
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
114 ;; ;;; Extremely usefull, it allows you to create `nameless' recursive functions
115 ;; (macroexpand-1 '(alambda (lst)
116 ;; (cond ((null lst) nil)
117 ;; (t (self (cdr lst))) )))
118 ;; (funcall (alambda (lst)
119 ;; (cond ((null lst) nil)
120 ;; (t (cons lst (self (cdr lst)))) ))
121 ;; '(1 2 3 4 5) )
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
122
123 ;;; Anaphoric macros that check secondary return values for success
124
125 (defmacro aif2 (test &optional then else)
126 (let ((win (gensym "AIF2-")))
127 `(multiple-value-bind (it ,win) ,test
0725eb6 @smithzvk Well, a ton of various changes because I haven't made a commit in a
authored
128 (declare (ignorable it))
129 (if ,win ,then ,else) )))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
130
131 (defmacro awhen2 (test &body body)
132 `(aif2 ,test
133 (progn ,@body) ))
134
135 (defmacro awhile2 (test &body body)
136 (let ((flag (gensym "AWHILE2-")))
137 `(let ((,flag t))
138 (while ,flag
0725eb6 @smithzvk Well, a ton of various changes because I haven't made a commit in a
authored
139 (aif2 ,test
140 (progn ,@body)
141 (setq ,flag nil) )))))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
142
143 (defmacro acond2 (&rest clauses)
144 (if (null clauses)
145 nil
146 (let ((cl1 (car clauses))
147 (val (gensym "ACOND2-"))
148 (win (gensym "ACOND2-")) )
149 `(multiple-value-bind (,val ,win) ,(car cl1)
0725eb6 @smithzvk Well, a ton of various changes because I haven't made a commit in a
authored
150 (if ,win
151 (let ((it ,val))
152 (declare (ignorable it))
153 ,@(cdr cl1) )
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
154 (acond2 ,@(cdr clauses)) )))))
155
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
156 ;; ;; Examples
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
157
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
158 ;; ;;; The meat of a memoized function
159 ;; (macroexpand
160 ;; '(aif2 (gethash args hash)
161 ;; it
162 ;; (setf (gethash args hash)
163 ;; (funcall fn args) )))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
164
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
165 ;; (macroexpand
166 ;; '(awhen2 (gethash key hash)
167 ;; it ))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
168
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
169 ;; (macroexpand
170 ;; '(awhile2 (gethash key hash)
171 ;; (do-some-stuff)
172 ;; (maybe-set (gethash key hash)) ))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
173
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
174 ;; (macroexpand
175 ;; '(acond2 ((test1) it)
176 ;; ((test2) (not it))
177 ;; (t 'goodbye) ))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
178
0725eb6 @smithzvk Well, a ton of various changes because I haven't made a commit in a
authored
179 (defmacro a+ (&rest args)
180 "`it' bound to the previous term in the addition"
181 (a+expand args nil) )
182
183 (defun a+expand (args syms)
184 (if args
185 (let ((sym (gensym "A+EXPAND-")))
186 `(let* ((,sym ,(car args))
187 (it ,sym) )
188 ,(a+expand (cdr args)
189 (append syms (list sym)) )))
190 `(+ ,@syms) ))
191
192 (defmacro alist (&rest args)
193 "`it' bound to the previous term in the list"
194 (alist-expand args nil) )
195
196 (defun alist-expand (args syms)
197 (if args
198 (let ((sym (gensym "ALIST-EXPAND-")))
199 `(let* ((,sym ,(car args))
200 (it ,sym) )
201 ,(alist-expand (cdr args)
202 (append syms (list sym)) )))
203 `(list ,@syms) ))
204
205 (defmacro defanaph (name &key calls (rule :all))
206 "A macro for automating anahporic macro definitions."
207 (let* ((opname (or calls (pop-symbol name)))
208 (body (case rule
209 (:all `(anaphex1 args '(,opname)))
210 (:first `(anaphex2 ',opname args))
211 (:place `(anaphex3 ',opname args)) )))
212 `(defmacro ,name (&rest args)
213 ,body )))
214
215 (defun anaphex1 (args expr)
216 (if args
217 (let ((sym (gensym "ANAPHEX1-")))
218 `(let* ((,sym ,(car args))
219 (it ,sym) )
220 ,(anaphex (cdr args)
221 (append expr (list sym)) )))
222 expr ))
223
224 (defun anaphex2 (op args)
225 `(let ((it ,(car args))) (,op it ,@(cdr args))) )
226
227 (defun anaphex3 (op args)
228 `(_f (lambda (it) (,op it ,@(cdr args))) ,(car args)) )
229
230 (defun pop-symbol (sym)
231 (intern (subseq (symbol-name sym) 1)) )
232
233 ;; Examples
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
234
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
235 ;; ;;; These are not the most useful, perhaps they are better as examples
236 ;; (a+ 1 2 (/ 1 it) 4 (* 0.1 it))
237 ;; (alist 1 (+ it 1) (+ it 1))
3db7668 added anaphoric.lisp (a split from the monolithic on.lisp)
smithzv authored
238
3d54caa @smithzvk Now using Alexandria which replaces some utilities (copy-array,
authored
239 ;; (pop-symbol 'aif)
240 ;; (pop-symbol 'acond)
Something went wrong with that request. Please try again.