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 #:anaphora
  27   (:use #:common-lisp #:mdw.base))
  28 (in-package #:anaphora)
  29
  30 (export 'it)
  31
  32 (export 'aif)
  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
  38 (export 'aif2)
  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
  46 (export 'awhen)
  47 (defmacro awhen (cond &body body)
  48   "Bind `it' to result of COND when evaluating BODY."
  49   `(let ((it ,cond))
  50      (when it ,@body)))
  51
  52 (export 'awhen2)
  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
  60 (export 'aand)
  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
  72 (export 'awhile)
  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
  80 (export 'asetf)
  81 (defmacro asetf (&rest pairs)
  82   "Set PLACE to value of FORM; in FORM, `it' is bound to current value of
  83    PLACE."
  84   `(progn ,@(do ((list nil)
  85                  (pairs pairs (cddr pairs)))
  86                 ((endp pairs) (nreverse list))
  87               (unless (cdr pairs)
  88                 (error "Odd number of arguments to `asetf'."))
  89               (push (with-places/gensyms ((place (car pairs)))
  90                       `(let ((it ,place))
  91                          (declare (ignorable it))
  92                          (setf ,place ,(cadr pairs))))
  93                     list))))
  94
  95 (export 'acond)
  96 (defmacro acond (&rest clauses)
  97   "Like `cond', but in each clause the consequent has `it' bound to the value
  98    of its guard."
  99   (labels ((foo (clauses)
 100              (when clauses
 101                (let ((tmp (gensym))
 102                      (clause (car clauses)))
 103                  `(let ((,tmp ,(car clause)))
 104                     (if ,tmp
 105                         (let ((it ,tmp))
 106                           (declare (ignorable it))
 107                           ,@(cdr clause))
 108                         ,(foo (cdr clauses))))))))
 109     (foo clauses)))
 110
 111 ;;;----- That's all, folks --------------------------------------------------