anaphora: Add anaphoric macros.

diff --git a/anaphora.lisp b/anaphora.lisp
new file mode 100644 (file)
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 (file)
--- 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")