From: mdw <mdw>
Date: Mon, 13 Feb 2006 11:54:57 +0000 (+0000)
Subject: anaphora: Add anaphoric macros.
X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/commitdiff_plain/b86088125dc0d9961a9089a99c37a39e033da718

anaphora: Add anaphoric macros.
---

diff --git a/anaphora.lisp b/anaphora.lisp
new file mode 100644
index 0000000..c7a4b08
--- /dev/null
+++ b/anaphora.lisp
@@ -0,0 +1,106 @@
+;;; -*-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 --------------------------------------------------
diff --git a/mdw.asd b/mdw.asd
index d65d502..32ad40d 100644
--- a/mdw.asd
+++ b/mdw.asd
@@ -6,6 +6,7 @@
 
 (defsystem "mdw"
   :components ((:file "mdw-base")
+	       (:file "anaphora")
 	       (:file "sys-base")
 	       (:file "str")
 	       (:file "collect")