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 (defpackage #:cffi-utils
  31   (:use #:common-lisp)
  32   (:export #:discard-docstring
  33            #:parse-body
  34            #:with-unique-names
  35            #:once-only
  36            #:ensure-list
  37            #:make-gensym-list
  38            #:symbolicate
  39            #:let-when
  40            #:bif
  41            #:post-incf
  42            #:single-bit-p
  43            #:warn-if-kw-or-belongs-to-cl))
  44
  45 (in-package #:cffi-utils)
  46
  47 ;;;# General Utilities
  48
  49 ;;; frodef's, see: http://paste.lisp.org/display/2771#1
  50 (defmacro post-incf (place &optional (delta 1) &environment env)
  51   "Increment PLACE by DELTA and return its previous value."
  52   (multiple-value-bind (dummies vals new setter getter)
  53       (get-setf-expansion place env)
  54     `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
  55        (prog1 ,(car new)
  56          (setq ,(car new) (+ ,(car new) ,delta))
  57          ,setter))))
  58
  59 (defun ensure-list (x)
  60   "Make into list if atom."
  61   (if (listp x) x (list x)))
  62
  63 (defmacro discard-docstring (body-var &optional force)
  64   "Discards the first element of the list in body-var if it's a
  65 string and the only element (or if FORCE is T)."
  66   `(when (and (stringp (car ,body-var)) (or ,force (cdr ,body-var)))
  67      (pop ,body-var)))
  68
  69 ;;; Parse a body of code, removing an optional documentation string
  70 ;;; and declaration forms.  Returns the actual body, docstring, and
  71 ;;; declarations as three multiple values.
  72 (defun parse-body (body)
  73   (let ((docstring nil)
  74         (declarations nil))
  75     (when (and (stringp (car body)) (cdr body))
  76       (setf docstring (pop body)))
  77     (loop while (and (consp (car body)) (eql (caar body) 'cl:declare))
  78           do (push (pop body) declarations))
  79     (values body docstring (nreverse declarations))))
  80
  81 ;;; LET-IF (renamed to BIF) and LET-WHEN taken from KMRCL
  82 (defmacro let-when ((var test-form) &body body)
  83   `(let ((,var ,test-form))
  84       (when ,var ,@body)))
  85
  86 (defmacro bif ((var test-form) if-true &optional if-false)
  87   `(let ((,var ,test-form))
  88       (if ,var ,if-true ,if-false)))
  89
  90 ;;; ONCE-ONLY macro taken from PAIP
  91 (defun starts-with (list x)
  92   "Is x a list whose first element is x?"
  93   (and (consp list) (eql (first list) x)))
  94
  95 (defun side-effect-free? (exp)
  96   "Is exp a constant, variable, or function,
  97   or of the form (THE type x) where x is side-effect-free?"
  98   (or (atom exp) (constantp exp)
  99       (starts-with exp 'function)
 100       (and (starts-with exp 'the)
 101            (side-effect-free? (third exp)))))
 102
 103 (defmacro once-only (variables &rest body)
 104   "Returns the code built by BODY.  If any of VARIABLES
 105   might have side effects, they are evaluated once and stored
 106   in temporary variables that are then passed to BODY."
 107   (assert (every #'symbolp variables))
 108   (let ((temps nil))
 109     (dotimes (i (length variables)) (push (gensym "ONCE") temps))
 110     `(if (every #'side-effect-free? (list .,variables))
 111          (progn .,body)
 112          (list 'let
 113                ,`(list ,@(mapcar #'(lambda (tmp var)
 114                                      `(list ',tmp ,var))
 115                                  temps variables))
 116                (let ,(mapcar #'(lambda (var tmp) `(,var ',tmp))
 117                              variables temps)
 118                  .,body)))))
 119
 120 ;;;; The following utils were taken from SBCL's
 121 ;;;; src/code/*-extensions.lisp
 122
 123 ;;; Automate an idiom often found in macros:
 124 ;;;   (LET ((FOO (GENSYM "FOO"))
 125 ;;;         (MAX-INDEX (GENSYM "MAX-INDEX-")))
 126 ;;;     ...)
 127 ;;;
 128 ;;; "Good notation eliminates thought." -- Eric Siggia
 129 ;;;
 130 ;;; Incidentally, this is essentially the same operator which
 131 ;;; _On Lisp_ calls WITH-GENSYMS.
 132 (defmacro with-unique-names (symbols &body body)
 133   `(let ,(mapcar (lambda (symbol)
 134                    (let* ((symbol-name (symbol-name symbol))
 135                           (stem (if (every #'alpha-char-p symbol-name)
 136                                     symbol-name
 137                                     (concatenate 'string symbol-name "-"))))
 138                      `(,symbol (gensym ,stem))))
 139                  symbols)
 140      ,@body))
 141
 142 (defun make-gensym-list (n)
 143   "Return a list of N gensyms."
 144   (loop repeat n collect (gensym)))
 145
 146 (defun symbolicate (&rest things)
 147   "Concatenate together the names of some strings and symbols,
 148 producing a symbol in the current package."
 149   (let* ((length (reduce #'+ things
 150                          :key (lambda (x) (length (string x)))))
 151          (name (make-array length :element-type 'character)))
 152     (let ((index 0))
 153       (dolist (thing things (values (intern name)))
 154         (let* ((x (string thing))
 155                (len (length x)))
 156           (replace name x :start1 index)
 157           (incf index len))))))
 158
 159 (defun single-bit-p (integer)
 160   "Answer whether INTEGER, which must be an integer, is a single
 161 set twos-complement bit."
 162   (if (<= integer 0)
 163     nil                       ;infinite set bits for negatives
 164     (loop until (logbitp 0 integer)
 165          do (setf integer (ash integer -1))
 166          finally (return (zerop (ash integer -1))))))
 167
 168 ;;; This function is here because it needs to be defined early.
 169 ;;;
 170 ;;; This function is used by DEFINE-PARSE-METHOD and DEFCTYPE to warn
 171 ;;; users when they're defining types whose names belongs to the
 172 ;;; KEYWORD or CL packages.  CFFI itself gets to use keywords without
 173 ;;; a warning though.
 174 (defun warn-if-kw-or-belongs-to-cl (name)
 175   (let ((package (symbol-package name)))
 176     (when (or (eq package (find-package '#:cl))
 177               (and (not (eq *package* (find-package '#:cffi)))
 178                    (eq package (find-package '#:keyword))))
 179       (warn "Defining a foreign type named ~S.  This symbol belongs to the ~A ~
 180              package and that may interfere with other code using CFFI."
 181             name (package-name package)))))
 182
 183 ;(defun deprecation-warning (bad-name &optional good-name)
 184 ;  (warn "using deprecated ~S~@[, should use ~S instead~]"
 185 ;        bad-name
 186 ;        good-name))
 187
 188 ;;; Anaphoric macros
 189 ;(defmacro awhen (test &body body)
 190 ;  `(let ((it ,test))
 191 ;     (when it ,@body)))
 192
 193 ;(defmacro acond (&rest clauses)
 194 ;  (if (null clauses)
 195 ;      `()
 196 ;      (destructuring-bind ((test &body body) &rest rest) clauses
 197 ;        (once-only (test)
 198 ;          `(if ,test
 199 ;               (let ((it ,test)) (declare (ignorable it)),@body)
 200 ;               (acond ,@rest))))))