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. |
16 | ;;; |
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. |
21 | ;;; |
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 | |
26 | (defpackage #:mdw.anaphora |
27 | (:use #:common-lisp) |
28 | (:export #:it |
29 | #:aif #:aif2 #:awhen #:awhen2 |
30 | #:aand #:awhile #:asetf #:acond)) |
31 | (in-package #:mdw.anaphora) |
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))))) |
37 | (defmacro aif2 (cond then &optional else) |
38 | "Bind `it' to first value of COND; switch on second." |
39 | (let ((tmp (gensym))) |
40 | `(multiple-value-bind (it ,tmp) ,cond |
41 | (declare (ignorable it)) |
42 | (if ,tmp ,then ,@(and else (list else)))))) |
43 | |
44 | (defmacro awhen (cond &body body) |
45 | "Bind `it' to result of COND when evaluating BODY." |
46 | `(let ((it ,cond)) |
47 | (when it ,@body))) |
48 | (defmacro awhen2 (cond &body body) |
49 | "Bind `it' to first value of COND; switch on second." |
50 | (let ((tmp (gensym))) |
51 | `(multiple-value-bind (it ,tmp) ,cond |
52 | (declare (ignorable it)) |
53 | (when ,tmp ,@body)))) |
54 | |
55 | (defmacro aand (&rest things) |
56 | "Like `and', with `it' bound to previous value." |
57 | (labels ((foo (things) |
58 | (if (cdr things) |
59 | `(let ((it ,(car things))) |
60 | (if it ,(foo (cdr things)))) |
61 | (car things)))) |
62 | (if things |
63 | (foo things) |
64 | t))) |
65 | |
66 | (defmacro awhile (cond &body body) |
67 | "Like `while', with `it' bound to value of COND in BODY." |
68 | `(loop |
69 | (let ((it ,cond)) |
70 | (unless it (return)) |
71 | ,@body))) |
72 | |
73 | (defmacro asetf (&rest pairs &environment env) |
74 | "Set PLACE to value of FORM; in FORM, `it' is bound to current value of |
75 | PLACE." |
76 | (labels ((foo (pairs) |
77 | (when pairs |
78 | (let ((place (car pairs)) |
79 | (form (cadr pairs)) |
80 | (rest (cddr pairs))) |
81 | (cons (multiple-value-bind |
82 | (valtmps valforms newtmps setform getform) |
83 | (get-setf-expansion place env) |
84 | `(let* ,(mapcar #'list valtmps valforms) |
85 | (let* ((it ,getform) |
86 | (,(car newtmps) ,form)) |
87 | ,setform))) |
88 | (foo rest)))))) |
89 | (cons 'progn (foo pairs)))) |
90 | |
91 | (defmacro acond (&rest clauses) |
92 | "Like `cond', but in each clause the consequent has `it' bound to the value |
93 | of its guard." |
94 | (labels ((foo (clauses) |
95 | (when clauses |
96 | (let ((tmp (gensym)) |
97 | (clause (car clauses))) |
98 | `(let ((,tmp ,(car clause))) |
99 | (if ,tmp |
100 | (let ((it ,tmp)) |
101 | (declare (ignorable it)) |
102 | ,@(cdr clause)) |
103 | ,(foo (cdr clauses)))))))) |
104 | (foo clauses))) |
105 | |
106 | ;;;----- That's all, folks -------------------------------------------------- |