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 (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 &environment env)
  82   "Set PLACE to value of FORM; in FORM, `it' is bound to current value of
  83    PLACE."
  84   (labels ((foo (pairs)
  85              (when pairs
  86                (let ((place (car pairs))
  87                      (form (cadr pairs))
  88                      (rest (cddr pairs)))
  89                  (cons (multiple-value-bind
  90                            (valtmps valforms newtmps setform getform)
  91                            (get-setf-expansion place env)
  92                          `(let* ,(mapcar #'list valtmps valforms)
  93                             (let* ((it ,getform)
  94                                    (,(car newtmps) ,form))
  95                               ,setform)))
  96                        (foo rest))))))
  97     (cons 'progn (foo pairs))))
  98
  99 (export 'acond)
 100 (defmacro acond (&rest clauses)
 101   "Like `cond', but in each clause the consequent has `it' bound to the value
 102    of its guard."
 103   (labels ((foo (clauses)
 104              (when clauses
 105                (let ((tmp (gensym))
 106                      (clause (car clauses)))
 107                  `(let ((,tmp ,(car clause)))
 108                     (if ,tmp
 109                         (let ((it ,tmp))
 110                           (declare (ignorable it))
 111                           ,@(cdr clause))
 112                         ,(foo (cdr clauses))))))))
 113     (foo clauses)))
 114
 115 ;;;----- That's all, folks --------------------------------------------------