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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Anaphoric extensions
   4 ;;;
   5 ;;; (c) 2005 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 2 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software Foundation,
  22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 (defpackage #:anaphora
  25   (:use #:common-lisp #:mdw.base))
  26 (in-package #:anaphora)
  27
  28 (export 'it)
  29
  30 (export 'aif)
  31 (defmacro aif (cond then &optional else)
  32   "Bind `it' to result of COND when evaluating THEN or ELSE."
  33   `(let ((it ,cond))
  34      (if it ,then ,@(and else (list else)))))
  35
  36 (export 'aif2)
  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 (export 'awhen)
  45 (defmacro awhen (cond &body body)
  46   "Bind `it' to result of COND when evaluating BODY."
  47   `(let ((it ,cond))
  48      (when it ,@body)))
  49
  50 (export 'awhen2)
  51 (defmacro awhen2 (cond &body body)
  52   "Bind `it' to first value of COND; switch on second."
  53   (let ((tmp (gensym)))
  54     `(multiple-value-bind (it ,tmp) ,cond
  55        (declare (ignorable it))
  56        (when ,tmp ,@body))))
  57
  58 (export 'aand)
  59 (defmacro aand (&rest things)
  60   "Like `and', with `it' bound to previous value."
  61   (labels ((foo (things)
  62              (if (cdr things)
  63                  `(let ((it ,(car things)))
  64                     (if it ,(foo (cdr things))))
  65                  (car things))))
  66     (if things
  67         (foo things)
  68         t)))
  69
  70 (export 'awhile)
  71 (defmacro awhile (cond &body body)
  72   "Like `while', with `it' bound to value of COND in BODY."
  73   `(loop
  74      (let ((it ,cond))
  75        (unless it (return))
  76        ,@body)))
  77
  78 (export 'asetf)
  79 (defmacro asetf (&rest pairs)
  80   "Set PLACE to value of FORM; in FORM, `it' is bound to current value of
  81    PLACE."
  82   `(progn ,@(do ((list nil)
  83                  (pairs pairs (cddr pairs)))
  84                 ((endp pairs) (nreverse list))
  85               (unless (cdr pairs)
  86                 (error "Odd number of arguments to `asetf'."))
  87               (push (with-places/gensyms ((place (car pairs)))
  88                       `(let ((it ,place))
  89                          (declare (ignorable it))
  90                          (setf ,place ,(cadr pairs))))
  91                     list))))
  92
  93 (export 'acond)
  94 (defmacro acond (&rest clauses)
  95   "Like `cond', but in each clause the consequent has `it' bound to the value
  96    of its guard."
  97   (labels ((foo (clauses)
  98              (when clauses
  99                (let ((tmp (gensym))
 100                      (clause (car clauses)))
 101                  `(let ((,tmp ,(car clause)))
 102                     (if ,tmp
 103                         (let ((it ,tmp))
 104                           (declare (ignorable it))
 105                           ,@(cdr clause))
 106                         ,(foo (cdr clauses))))))))
 107     (foo clauses)))
 108
 109 ;;;----- That's all, folks --------------------------------------------------