Commit | Line | Data |
---|---|---|
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 |
0eed4749 | 27 | (:use #:common-lisp #:mdw.base)) |
1dc0d275 | 28 | (in-package #:anaphora) |
b8608812 | 29 | |
e8567770 MW |
30 | (export 'it) |
31 | ||
32 | (export 'aif) | |
b8608812 | 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 | |
e8567770 | 38 | (export 'aif2) |
b8608812 | 39 | (defmacro aif2 (cond then &optional else) |
40 | "Bind `it' to first value of COND; switch on second." | |
41 | (let ((tmp (gensym))) | |
42 | `(multiple-value-bind (it ,tmp) ,cond | |
43 | (declare (ignorable it)) | |
44 | (if ,tmp ,then ,@(and else (list else)))))) | |
45 | ||
e8567770 | 46 | (export 'awhen) |
b8608812 | 47 | (defmacro awhen (cond &body body) |
48 | "Bind `it' to result of COND when evaluating BODY." | |
49 | `(let ((it ,cond)) | |
50 | (when it ,@body))) | |
0ff9df03 | 51 | |
e8567770 | 52 | (export 'awhen2) |
b8608812 | 53 | (defmacro awhen2 (cond &body body) |
54 | "Bind `it' to first value of COND; switch on second." | |
55 | (let ((tmp (gensym))) | |
56 | `(multiple-value-bind (it ,tmp) ,cond | |
57 | (declare (ignorable it)) | |
58 | (when ,tmp ,@body)))) | |
59 | ||
e8567770 | 60 | (export 'aand) |
b8608812 | 61 | (defmacro aand (&rest things) |
62 | "Like `and', with `it' bound to previous value." | |
63 | (labels ((foo (things) | |
64 | (if (cdr things) | |
65 | `(let ((it ,(car things))) | |
66 | (if it ,(foo (cdr things)))) | |
67 | (car things)))) | |
68 | (if things | |
69 | (foo things) | |
70 | t))) | |
71 | ||
e8567770 | 72 | (export 'awhile) |
b8608812 | 73 | (defmacro awhile (cond &body body) |
74 | "Like `while', with `it' bound to value of COND in BODY." | |
75 | `(loop | |
76 | (let ((it ,cond)) | |
77 | (unless it (return)) | |
78 | ,@body))) | |
79 | ||
e8567770 | 80 | (export 'asetf) |
0eed4749 | 81 | (defmacro asetf (&rest pairs) |
b8608812 | 82 | "Set PLACE to value of FORM; in FORM, `it' is bound to current value of |
0ff9df03 | 83 | PLACE." |
0eed4749 MW |
84 | `(progn ,@(do ((list nil) |
85 | (pairs pairs (cddr pairs))) | |
86 | ((endp pairs) (nreverse list)) | |
87 | (unless (cdr pairs) | |
88 | (error "Odd number of arguments to `asetf'.")) | |
89 | (push (with-places/gensyms ((place (car pairs))) | |
90 | `(let ((it ,place)) | |
91 | (declare (ignorable it)) | |
92 | (setf ,place ,(cadr pairs)))) | |
93 | list)))) | |
b2c12b4e | 94 | |
e8567770 | 95 | (export 'acond) |
b8608812 | 96 | (defmacro acond (&rest clauses) |
97 | "Like `cond', but in each clause the consequent has `it' bound to the value | |
0ff9df03 | 98 | of its guard." |
b8608812 | 99 | (labels ((foo (clauses) |
100 | (when clauses | |
101 | (let ((tmp (gensym)) | |
102 | (clause (car clauses))) | |
103 | `(let ((,tmp ,(car clause))) | |
104 | (if ,tmp | |
105 | (let ((it ,tmp)) | |
106 | (declare (ignorable it)) | |
107 | ,@(cdr clause)) | |
108 | ,(foo (cdr clauses)))))))) | |
109 | (foo clauses))) | |
110 | ||
111 | ;;;----- That's all, folks -------------------------------------------------- |