external/cffi.darcs/src/strings.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; strings.lisp --- Operations on foreign strings.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   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 ;;;# Foreign String Conversion
  31 ;;;
  32 ;;; Functions for converting NULL-terminated C-strings to Lisp strings
  33 ;;; and vice versa.  Currently this is blithely ignorant of encoding
  34 ;;; and assumes characters can fit in 8 bits.
  35
  36 (defun lisp-string-to-foreign (string ptr size)
  37   "Copy at most SIZE-1 characters from a Lisp STRING to PTR.
  38 The foreign string will be null-terminated."
  39   (decf size)
  40   (etypecase string
  41     (string
  42      (loop with i = 0 for char across string
  43            while (< i size)
  44            do (%mem-set (char-code char) ptr :unsigned-char (post-incf i))
  45            finally (%mem-set 0 ptr :unsigned-char i)))
  46     ((array (unsigned-byte 8))
  47      (loop with i = 0 for elt across string
  48            while (< i size)
  49            do (%mem-set elt ptr :unsigned-char (post-incf i))
  50            finally (%mem-set 0 ptr :unsigned-char i)))))
  51
  52 (defun foreign-string-to-lisp (ptr &optional (size array-total-size-limit)
  53                                (null-terminated-p t))
  54   "Copy at most SIZE characters from PTR into a Lisp string.
  55 If PTR is a null pointer, returns nil."
  56   (unless (null-pointer-p ptr)
  57     (with-output-to-string (s)
  58       (loop for i fixnum from 0 below size
  59             for code = (mem-ref ptr :unsigned-char i)
  60             until (and null-terminated-p (zerop code))
  61             do (write-char (code-char code) s)))))
  62
  63 ;;;# Using Foreign Strings
  64
  65 (defun foreign-string-alloc (string)
  66   "Allocate a foreign string containing Lisp string STRING.
  67 The string must be freed with FOREIGN-STRING-FREE."
  68   (check-type string (or string (array (unsigned-byte 8))))
  69   (let* ((length (1+ (length string)))
  70          (ptr (foreign-alloc :char :count length)))
  71     (lisp-string-to-foreign string ptr length)
  72     ptr))
  73
  74 (defun foreign-string-free (ptr)
  75   "Free a foreign string allocated by FOREIGN-STRING-ALLOC."
  76   (foreign-free ptr))
  77
  78 (defmacro with-foreign-string ((var lisp-string) &body body)
  79   "Bind VAR to a foreign string containing LISP-STRING in BODY."
  80   (with-unique-names (str length)
  81     `(let* ((,str ,lisp-string)
  82             (,length (progn
  83                        (check-type ,str (or string (array (unsigned-byte 8))))
  84                        (1+ (length ,str)))))
  85        (with-foreign-pointer (,var ,length)
  86          (lisp-string-to-foreign ,str ,var ,length)
  87          ,@body))))
  88
  89 (defmacro with-foreign-strings (bindings &body body)
  90   (if bindings
  91       `(with-foreign-string ,(first bindings)
  92          (with-foreign-strings ,(rest bindings)
  93            ,@body))
  94       `(progn ,@body)))
  95
  96 (defmacro with-foreign-pointer-as-string ((var size &optional size-var)
  97                                           &body body)
  98   "Like WITH-FOREIGN-POINTER except VAR as a Lisp string is used as
  99 the return value of an implicit PROGN around BODY."
 100   `(with-foreign-pointer (,var ,size ,size-var)
 101      (progn
 102        ,@body
 103        (foreign-string-to-lisp ,var))))
 104
 105 ;;;# Automatic Conversion of Foreign Strings
 106
 107 (define-foreign-type foreign-string-type ()
 108   ()
 109   (:actual-type :pointer)
 110   (:simple-parser :string))
 111
 112 (defmethod translate-to-foreign ((s string) (type foreign-string-type))
 113   (values (foreign-string-alloc s) t))
 114
 115 (defmethod translate-to-foreign (obj (type foreign-string-type))
 116   (cond
 117     ((pointerp obj)
 118      (values obj nil))
 119     ((typep obj '(array (unsigned-byte 8)))
 120      (values (foreign-string-alloc obj) t))
 121     (t (error "~A is not a Lisp string, (array (unsigned-byte 8)) or pointer."
 122               obj))))
 123
 124 (defmethod translate-from-foreign (ptr (type foreign-string-type))
 125   (foreign-string-to-lisp ptr))
 126
 127 (defmethod free-translated-object (ptr (type foreign-string-type) free-p)
 128   (when free-p
 129     (foreign-string-free ptr)))
 130
 131 ;;; STRING+PTR
 132
 133 (define-foreign-type foreign-string+ptr-type (foreign-string-type)
 134   ()
 135   (:simple-parser :string+ptr))
 136
 137 (defmethod translate-from-foreign (value (type foreign-string+ptr-type))
 138   (list (foreign-string-to-lisp value) value))