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)
  28   (:export #:it
  29            #:aif #:aif2 #:awhen #:awhen2
  30            #:aand #:awhile #:asetf #:acond))
  31 (in-package #: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
  38 (defmacro aif2 (cond then &optional else)
  39   "Bind `it' to first value of COND; switch on second."
  40   (let ((tmp (gensym)))
  41     `(multiple-value-bind (it ,tmp) ,cond
  42        (declare (ignorable it))
  43        (if ,tmp ,then ,@(and else (list else))))))
  44
  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 (defmacro awhen2 (cond &body body)
  51   "Bind `it' to first value of COND; switch on second."
  52   (let ((tmp (gensym)))
  53     `(multiple-value-bind (it ,tmp) ,cond
  54        (declare (ignorable it))
  55        (when ,tmp ,@body))))
  56
  57 (defmacro aand (&rest things)
  58   "Like `and', with `it' bound to previous value."
  59   (labels ((foo (things)
  60              (if (cdr things)
  61                  `(let ((it ,(car things)))
  62                     (if it ,(foo (cdr things))))
  63                  (car things))))
  64     (if things
  65         (foo things)
  66         t)))
  67
  68 (defmacro awhile (cond &body body)
  69   "Like `while', with `it' bound to value of COND in BODY."
  70   `(loop
  71      (let ((it ,cond))
  72        (unless it (return))
  73        ,@body)))
  74
  75 (defmacro asetf (&rest pairs &environment env)
  76   "Set PLACE to value of FORM; in FORM, `it' is bound to current value of
  77    PLACE."
  78   (labels ((foo (pairs)
  79              (when pairs
  80                (let ((place (car pairs))
  81                      (form (cadr pairs))
  82                      (rest (cddr pairs)))
  83                  (cons (multiple-value-bind
  84                            (valtmps valforms newtmps setform getform)
  85                            (get-setf-expansion place env)
  86                          `(let* ,(mapcar #'list valtmps valforms)
  87                             (let* ((it ,getform)
  88                                    (,(car newtmps) ,form))
  89                               ,setform)))
  90                        (foo rest))))))
  91     (cons 'progn (foo pairs))))
  92
  93 (defmacro acond (&rest clauses)
  94   "Like `cond', but in each clause the consequent has `it' bound to the value
  95    of its guard."
  96   (labels ((foo (clauses)
  97              (when clauses
  98                (let ((tmp (gensym))
  99                      (clause (car clauses)))
 100                  `(let ((,tmp ,(car clause)))
 101                     (if ,tmp
 102                         (let ((it ,tmp))
 103                           (declare (ignorable it))
 104                           ,@(cdr clause))
 105                         ,(foo (cdr clauses))))))))
 106     (foo clauses)))
 107
 108 ;;;----- That's all, folks --------------------------------------------------