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 |
e8567770 | 27 | (:use #:common-lisp)) |
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) |
b8608812 | 81 | (defmacro asetf (&rest pairs &environment env) |
82 | "Set PLACE to value of FORM; in FORM, `it' is bound to current value of | |
0ff9df03 | 83 | PLACE." |
b8608812 | 84 | (labels ((foo (pairs) |
85 | (when pairs | |
86 | (let ((place (car pairs)) | |
87 | (form (cadr pairs)) | |
88 | (rest (cddr pairs))) | |
89 | (cons (multiple-value-bind | |
90 | (valtmps valforms newtmps setform getform) | |
91 | (get-setf-expansion place env) | |
92 | `(let* ,(mapcar #'list valtmps valforms) | |
93 | (let* ((it ,getform) | |
94 | (,(car newtmps) ,form)) | |
95 | ,setform))) | |
96 | (foo rest)))))) | |
97 | (cons 'progn (foo pairs)))) | |
b2c12b4e | 98 | |
e8567770 | 99 | (export 'acond) |
b8608812 | 100 | (defmacro acond (&rest clauses) |
101 | "Like `cond', but in each clause the consequent has `it' bound to the value | |
0ff9df03 | 102 | of its guard." |
b8608812 | 103 | (labels ((foo (clauses) |
104 | (when clauses | |
105 | (let ((tmp (gensym)) | |
106 | (clause (car clauses))) | |
107 | `(let ((,tmp ,(car clause))) | |
108 | (if ,tmp | |
109 | (let ((it ,tmp)) | |
110 | (declare (ignorable it)) | |
111 | ,@(cdr clause)) | |
112 | ,(foo (cdr clauses)))))))) | |
113 | (foo clauses))) | |
114 | ||
115 | ;;;----- That's all, folks -------------------------------------------------- |