chiark - git - mdw - lisp/blob - anaphora.lisp

   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 --------------------------------------------------