b8608812 |
1 | ;;; -*-lisp-*- |
2 | ;;; |
3 | ;;; $Id$ |
4 | ;;; |
5 | ;;; Anaphoric extensions |
6 | ;;; |
7 | ;;; (c) 2005 Straylight/Edgeware |
8 | ;;; |
9 | |
10 | ;;;----- Licensing notice --------------------------------------------------- |
11 | ;;; |
12 | ;;; This program is free software; you can redistribute it and/or modify |
13 | ;;; it under the terms of the GNU General Public License as published by |
14 | ;;; the Free Software Foundation; either version 2 of the License, or |
15 | ;;; (at your option) any later version. |
b2c12b4e |
16 | ;;; |
b8608812 |
17 | ;;; This program is distributed in the hope that it will be useful, |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
20 | ;;; GNU General Public License for more details. |
b2c12b4e |
21 | ;;; |
b8608812 |
22 | ;;; You should have received a copy of the GNU General Public License |
23 | ;;; along with this program; if not, write to the Free Software Foundation, |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
25 | |
1dc0d275 |
26 | (defpackage #:anaphora |
b8608812 |
27 | (:use #:common-lisp) |
28 | (:export #:it |
29 | #:aif #:aif2 #:awhen #:awhen2 |
30 | #:aand #:awhile #:asetf #:acond)) |
1dc0d275 |
31 | (in-package #:anaphora) |
b8608812 |
32 | |
33 | (defmacro aif (cond then &optional else) |
34 | "Bind `it' to result of COND when evaluating THEN or ELSE." |
35 | `(let ((it ,cond)) |
36 | (if it ,then ,@(and else (list else))))) |
0ff9df03 |
37 | |
b8608812 |
38 | (defmacro aif2 (cond then &optional else) |
39 | "Bind `it' to first value of COND; switch on second." |
40 | (let ((tmp (gensym))) |
41 | `(multiple-value-bind (it ,tmp) ,cond |
42 | (declare (ignorable it)) |
43 | (if ,tmp ,then ,@(and else (list else)))))) |
44 | |
45 | (defmacro awhen (cond &body body) |
46 | "Bind `it' to result of COND when evaluating BODY." |
47 | `(let ((it ,cond)) |
48 | (when it ,@body))) |
0ff9df03 |
49 | |
b8608812 |
50 | (defmacro awhen2 (cond &body body) |
51 | "Bind `it' to first value of COND; switch on second." |
52 | (let ((tmp (gensym))) |
53 | `(multiple-value-bind (it ,tmp) ,cond |
54 | (declare (ignorable it)) |
55 | (when ,tmp ,@body)))) |
56 | |
57 | (defmacro aand (&rest things) |
58 | "Like `and', with `it' bound to previous value." |
59 | (labels ((foo (things) |
60 | (if (cdr things) |
61 | `(let ((it ,(car things))) |
62 | (if it ,(foo (cdr things)))) |
63 | (car things)))) |
64 | (if things |
65 | (foo things) |
66 | t))) |
67 | |
68 | (defmacro awhile (cond &body body) |
69 | "Like `while', with `it' bound to value of COND in BODY." |
70 | `(loop |
71 | (let ((it ,cond)) |
72 | (unless it (return)) |
73 | ,@body))) |
74 | |
75 | (defmacro asetf (&rest pairs &environment env) |
76 | "Set PLACE to value of FORM; in FORM, `it' is bound to current value of |
0ff9df03 |
77 | PLACE." |
b8608812 |
78 | (labels ((foo (pairs) |
79 | (when pairs |
80 | (let ((place (car pairs)) |
81 | (form (cadr pairs)) |
82 | (rest (cddr pairs))) |
83 | (cons (multiple-value-bind |
84 | (valtmps valforms newtmps setform getform) |
85 | (get-setf-expansion place env) |
86 | `(let* ,(mapcar #'list valtmps valforms) |
87 | (let* ((it ,getform) |
88 | (,(car newtmps) ,form)) |
89 | ,setform))) |
90 | (foo rest)))))) |
91 | (cons 'progn (foo pairs)))) |
b2c12b4e |
92 | |
b8608812 |
93 | (defmacro acond (&rest clauses) |
94 | "Like `cond', but in each clause the consequent has `it' bound to the value |
0ff9df03 |
95 | of its guard." |
b8608812 |
96 | (labels ((foo (clauses) |
97 | (when clauses |
98 | (let ((tmp (gensym)) |
99 | (clause (car clauses))) |
100 | `(let ((,tmp ,(car clause))) |
101 | (if ,tmp |
102 | (let ((it ,tmp)) |
103 | (declare (ignorable it)) |
104 | ,@(cdr clause)) |
105 | ,(foo (cdr clauses)))))))) |
106 | (foo clauses))) |
107 | |
108 | ;;;----- That's all, folks -------------------------------------------------- |