3rdparties/software/cffi_0.21.0/src/utils.lisp (3914 bytes)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; utils.lisp --- Various utilities. 4 ;;; 5 ;;; Copyright (C) 2005-2008, 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 #:cffi) 29 30 (defmacro discard-docstring (body-var &optional force) 31 "Discards the first element of the list in body-var if it's a 32 string and the only element (or if FORCE is T)." 33 `(when (and (stringp (car ,body-var)) (or ,force (cdr ,body-var))) 34 (pop ,body-var))) 35 36 (defun single-bit-p (integer) 37 "Answer whether INTEGER, which must be an integer, is a single 38 set twos-complement bit." 39 (if (<= integer 0) 40 nil ; infinite set bits for negatives 41 (loop until (logbitp 0 integer) 42 do (setf integer (ash integer -1)) 43 finally (return (zerop (ash integer -1)))))) 44 45 ;;; This function is here because it needs to be defined early. It's 46 ;;; used by DEFINE-PARSE-METHOD and DEFCTYPE to warn users when 47 ;;; they're defining types whose names belongs to the KEYWORD or CL 48 ;;; packages. CFFI itself gets to use keywords without a warning. 49 (defun warn-if-kw-or-belongs-to-cl (name) 50 (let ((package (symbol-package name))) 51 (when (and (not (eq *package* (find-package '#:cffi))) 52 (member package '(#:common-lisp #:keyword) 53 :key #'find-package)) 54 (warn "Defining a foreign type named ~S. This symbol belongs to the ~A ~ 55 package and that may interfere with other code using CFFI." 56 name (package-name package))))) 57 58 (define-condition obsolete-argument-warning (style-warning) 59 ((old-arg :initarg :old-arg :reader old-arg) 60 (new-arg :initarg :new-arg :reader new-arg)) 61 (:report (lambda (c s) 62 (format s "Keyword ~S is obsolete, please use ~S" 63 (old-arg c) (new-arg c))))) 64 65 (defun warn-obsolete-argument (old-arg new-arg) 66 (warn 'obsolete-argument-warning 67 :old-arg old-arg :new-arg new-arg)) 68 69 (defun split-if (test seq &optional (dir :before)) 70 (remove-if #'(lambda (x) (equal x (subseq seq 0 0))) 71 (loop for start fixnum = 0 72 then (if (eq dir :before) 73 stop 74 (the fixnum (1+ (the fixnum stop)))) 75 while (< start (length seq)) 76 for stop = (position-if test seq 77 :start (if (eq dir :elide) 78 start 79 (the fixnum (1+ start)))) 80 collect (subseq seq start 81 (if (and stop (eq dir :after)) 82 (the fixnum (1+ (the fixnum stop))) 83 stop)) 84 while stop)))