external/cffi.darcs/src/utils.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; utils.lisp --- Various utilities.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, Luis Oliveira  <loliveira(@)common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cl-user)
  29
  30 ;;; This package is for CFFI's internal use.  No effort is made to
  31 ;;; maintain backwards compatibility.  Use at your own risk.
  32 (defpackage #:cffi-utils
  33   (:use #:common-lisp #:alexandria)
  34   (:export #:discard-docstring
  35            #:symbolicate
  36            #:post-incf
  37            #:single-bit-p
  38            #:warn-if-kw-or-belongs-to-cl))
  39
  40 (in-package #:cffi-utils)
  41
  42 ;;;# General Utilities
  43
  44 ;;; frodef's, see: http://paste.lisp.org/display/2771#1
  45 (defmacro post-incf (place &optional (delta 1) &environment env)
  46   "Increment PLACE by DELTA and return its previous value."
  47   (multiple-value-bind (dummies vals new setter getter)
  48       (get-setf-expansion place env)
  49     `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
  50        (prog1 ,(car new)
  51          (setq ,(car new) (+ ,(car new) ,delta))
  52          ,setter))))
  53
  54 (defmacro discard-docstring (body-var &optional force)
  55   "Discards the first element of the list in body-var if it's a
  56 string and the only element (or if FORCE is T)."
  57   `(when (and (stringp (car ,body-var)) (or ,force (cdr ,body-var)))
  58      (pop ,body-var)))
  59
  60 (defun side-effect-free? (exp)
  61   "Is exp a constant, variable, or function,
  62   or of the form (THE type x) where x is side-effect-free?"
  63   (or (atom exp) (constantp exp)
  64       (starts-with exp 'function)
  65       (and (starts-with exp 'the)
  66            (side-effect-free? (third exp)))))
  67
  68 ;;;; The following utils were taken from SBCL's
  69 ;;;; src/code/*-extensions.lisp
  70
  71 (defun symbolicate (&rest things)
  72   "Concatenate together the names of some strings and symbols,
  73 producing a symbol in the current package."
  74   (let* ((length (reduce #'+ things
  75                          :key (lambda (x) (length (string x)))))
  76          (name (make-array length :element-type 'character)))
  77     (let ((index 0))
  78       (dolist (thing things (values (intern name)))
  79         (let* ((x (string thing))
  80                (len (length x)))
  81           (replace name x :start1 index)
  82           (incf index len))))))
  83
  84 (defun single-bit-p (integer)
  85   "Answer whether INTEGER, which must be an integer, is a single
  86 set twos-complement bit."
  87   (if (<= integer 0)
  88     nil                       ;infinite set bits for negatives
  89     (loop until (logbitp 0 integer)
  90          do (setf integer (ash integer -1))
  91          finally (return (zerop (ash integer -1))))))
  92
  93 ;;; This function is here because it needs to be defined early.
  94 ;;;
  95 ;;; This function is used by DEFINE-PARSE-METHOD and DEFCTYPE to warn
  96 ;;; users when they're defining types whose names belongs to the
  97 ;;; KEYWORD or CL packages.  CFFI itself gets to use keywords without
  98 ;;; a warning though.
  99 (defun warn-if-kw-or-belongs-to-cl (name)
 100   (let ((package (symbol-package name)))
 101     (when (or (eq package (find-package '#:cl))
 102               (and (not (eq *package* (find-package '#:cffi)))
 103                    (eq package (find-package '#:keyword))))
 104       (warn "Defining a foreign type named ~S.  This symbol belongs to the ~A ~
 105              package and that may interfere with other code using CFFI."
 106             name (package-name package)))))
 107
 108 ;(defun deprecation-warning (bad-name &optional good-name)
 109 ;  (warn "using deprecated ~S~@[, should use ~S instead~]"
 110 ;        bad-name
 111 ;        good-name))
 112
 113 ;;; Anaphoric macros
 114 ;(defmacro awhen (test &body body)
 115 ;  `(let ((it ,test))
 116 ;     (when it ,@body)))
 117
 118 ;(defmacro acond (&rest clauses)
 119 ;  (if (null clauses)
 120 ;      `()
 121 ;      (destructuring-bind ((test &body body) &rest rest) clauses
 122 ;        (once-only (test)
 123 ;          `(if ,test
 124 ;               (let ((it ,test)) (declare (ignorable it)),@body)
 125 ;               (acond ,@rest))))))