safely.lisp: SAFE-COPY shouldn't make two copies under CLisp.

[lisp] / anaphora.lisp

;;; -*-lisp-*-
;;;
;;; $Id$
;;;
;;; Anaphoric extensions
;;;
;;; (c) 2005 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(defpackage #:anaphora
  (:use #:common-lisp)
  (:export #:it
	   #:aif #:aif2 #:awhen #:awhen2
	   #:aand #:awhile #:asetf #:acond))
(in-package #:anaphora)

(defmacro aif (cond then &optional else)
  "Bind `it' to result of COND when evaluating THEN or ELSE."
  `(let ((it ,cond))
     (if it ,then ,@(and else (list else)))))

(defmacro aif2 (cond then &optional else)
  "Bind `it' to first value of COND; switch on second."
  (let ((tmp (gensym)))
    `(multiple-value-bind (it ,tmp) ,cond
       (declare (ignorable it))
       (if ,tmp ,then ,@(and else (list else))))))

(defmacro awhen (cond &body body)
  "Bind `it' to result of COND when evaluating BODY."
  `(let ((it ,cond))
     (when it ,@body)))

(defmacro awhen2 (cond &body body)
  "Bind `it' to first value of COND; switch on second."
  (let ((tmp (gensym)))
    `(multiple-value-bind (it ,tmp) ,cond
       (declare (ignorable it))
       (when ,tmp ,@body))))

(defmacro aand (&rest things)
  "Like `and', with `it' bound to previous value."
  (labels ((foo (things)
	     (if (cdr things)
		 `(let ((it ,(car things)))
		    (if it ,(foo (cdr things))))
		 (car things))))
    (if things
	(foo things)
	t)))

(defmacro awhile (cond &body body)
  "Like `while', with `it' bound to value of COND in BODY."
  `(loop
     (let ((it ,cond))
       (unless it (return))
       ,@body)))

(defmacro asetf (&rest pairs &environment env)
  "Set PLACE to value of FORM; in FORM, `it' is bound to current value of
   PLACE."
  (labels ((foo (pairs)
	     (when pairs
	       (let ((place (car pairs))
		     (form (cadr pairs))
		     (rest (cddr pairs)))
		 (cons (multiple-value-bind
			   (valtmps valforms newtmps setform getform)
			   (get-setf-expansion place env)
			 `(let* ,(mapcar #'list valtmps valforms)
			    (let* ((it ,getform)
				   (,(car newtmps) ,form))
			      ,setform)))
		       (foo rest))))))
    (cons 'progn (foo pairs))))

(defmacro acond (&rest clauses)
  "Like `cond', but in each clause the consequent has `it' bound to the value
   of its guard."
  (labels ((foo (clauses)
	     (when clauses
	       (let ((tmp (gensym))
		     (clause (car clauses)))
		 `(let ((,tmp ,(car clause)))
		    (if ,tmp
			(let ((it ,tmp))
			  (declare (ignorable it))
			  ,@(cdr clause))
			,(foo (cdr clauses))))))))
    (foo clauses)))

;;;----- That's all, folks --------------------------------------------------