utils/misc.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :iolib-utils)
  23
  24 (defmacro define-constant (name value &optional doc)
  25   `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
  26      ,@(when doc (list doc))))
  27
  28 (defun %check-bounds (sequence start end)
  29   (unless end (setf end (length sequence)))
  30   (when (> start end) (error "~S ~S wrong sequence bounds" start end))
  31   (values start end))
  32
  33 (defmacro return-if (block form)
  34   (let (($form$ (gensym "FORM-")))
  35     `(let ((,$form$ ,form))
  36        (when ,$form$ (return-from ,block ,$form$)))))
  37
  38 (defun featurep (feature)
  39   (etypecase feature
  40     (symbol (consp (member feature *features* :test #'eq)))
  41     (cons (ecase (first feature)
  42             ((or :or)   (some #'featurep (rest feature)))
  43             ((and :and) (every #'featurep (rest feature)))
  44             ((not :not) (and (third feature) (error "Incorrect feature expression: ~S" feature))
  45                         (not (featurep (second feature))))))))
  46
  47 (defun xnor (x1 x2)
  48   (not (eq (not x1) (not x2))))
  49
  50 (export '(define-constant %check-bounds return-if featurep xnor))