+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Anaphoric extensions
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.anaphora
+ (:use #:common-lisp)
+ (:export #:it
+ #:aif #:aif2 #:awhen #:awhen2
+ #:aand #:awhile #:asetf #:acond))
+(in-package #:mdw.anaphora)
+
+(defmacro aif (cond then &optional else)
+ "Bind `it' to result of COND when evaluating THEN or ELSE."
+ `(let ((it ,cond))
+ (if it ,then ,@(and else (list else)))))
+(defmacro aif2 (cond then &optional else)
+ "Bind `it' to first value of COND; switch on second."
+ (let ((tmp (gensym)))
+ `(multiple-value-bind (it ,tmp) ,cond
+ (declare (ignorable it))
+ (if ,tmp ,then ,@(and else (list else))))))
+
+(defmacro awhen (cond &body body)
+ "Bind `it' to result of COND when evaluating BODY."
+ `(let ((it ,cond))
+ (when it ,@body)))
+(defmacro awhen2 (cond &body body)
+ "Bind `it' to first value of COND; switch on second."
+ (let ((tmp (gensym)))
+ `(multiple-value-bind (it ,tmp) ,cond
+ (declare (ignorable it))
+ (when ,tmp ,@body))))
+
+(defmacro aand (&rest things)
+ "Like `and', with `it' bound to previous value."
+ (labels ((foo (things)
+ (if (cdr things)
+ `(let ((it ,(car things)))
+ (if it ,(foo (cdr things))))
+ (car things))))
+ (if things
+ (foo things)
+ t)))
+
+(defmacro awhile (cond &body body)
+ "Like `while', with `it' bound to value of COND in BODY."
+ `(loop
+ (let ((it ,cond))
+ (unless it (return))
+ ,@body)))
+
+(defmacro asetf (&rest pairs &environment env)
+ "Set PLACE to value of FORM; in FORM, `it' is bound to current value of
+PLACE."
+ (labels ((foo (pairs)
+ (when pairs
+ (let ((place (car pairs))
+ (form (cadr pairs))
+ (rest (cddr pairs)))
+ (cons (multiple-value-bind
+ (valtmps valforms newtmps setform getform)
+ (get-setf-expansion place env)
+ `(let* ,(mapcar #'list valtmps valforms)
+ (let* ((it ,getform)
+ (,(car newtmps) ,form))
+ ,setform)))
+ (foo rest))))))
+ (cons 'progn (foo pairs))))
+
+(defmacro acond (&rest clauses)
+ "Like `cond', but in each clause the consequent has `it' bound to the value
+of its guard."
+ (labels ((foo (clauses)
+ (when clauses
+ (let ((tmp (gensym))
+ (clause (car clauses)))
+ `(let ((,tmp ,(car clause)))
+ (if ,tmp
+ (let ((it ,tmp))
+ (declare (ignorable it))
+ ,@(cdr clause))
+ ,(foo (cdr clauses))))))))
+ (foo clauses)))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / commitdiff