uffi-compat/uffi-compat.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; uffi-compat.lisp --- UFFI compatibility layer for CFFI.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;; Copyright (C) 2005-2007, Luis Oliveira  <loliveira@common-lisp.net>
   7 ;;;
   8 ;;; Permission is hereby granted, free of charge, to any person
   9 ;;; obtaining a copy of this software and associated documentation
  10 ;;; files (the "Software"), to deal in the Software without
  11 ;;; restriction, including without limitation the rights to use, copy,
  12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  13 ;;; of the Software, and to permit persons to whom the Software is
  14 ;;; furnished to do so, subject to the following conditions:
  15 ;;;
  16 ;;; The above copyright notice and this permission notice shall be
  17 ;;; included in all copies or substantial portions of the Software.
  18 ;;;
  19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  26 ;;; DEALINGS IN THE SOFTWARE.
  27 ;;;
  28
  29 ;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg.
  30
  31 (defpackage #:cffi-uffi-compat
  32   (:nicknames #:uffi) ;; is this a good idea?
  33   (:use #:cl)
  34   (:export
  35
  36    ;; immediate types
  37    #:def-constant
  38    #:def-foreign-type
  39    #:def-type
  40    #:null-char-p
  41
  42    ;; aggregate types
  43    #:def-enum
  44    #:def-struct
  45    #:get-slot-value
  46    #:get-slot-pointer
  47    #:def-array-pointer
  48    #:deref-array
  49    #:def-union
  50
  51    ;; objects
  52    #:allocate-foreign-object
  53    #:free-foreign-object
  54    #:with-foreign-object
  55    #:with-foreign-objects
  56    #:size-of-foreign-type
  57    #:pointer-address
  58    #:deref-pointer
  59    #:ensure-char-character
  60    #:ensure-char-integer
  61    #:ensure-char-storable
  62    #:null-pointer-p
  63    #:make-null-pointer
  64    #:make-pointer
  65    #:+null-cstring-pointer+
  66    #:char-array-to-pointer
  67    #:with-cast-pointer
  68    #:def-foreign-var
  69    #:convert-from-foreign-usb8
  70    #:def-pointer-var
  71
  72    ;; string functions
  73    #:convert-from-cstring
  74    #:convert-to-cstring
  75    #:free-cstring
  76    #:with-cstring
  77    #:with-cstrings
  78    #:convert-from-foreign-string
  79    #:convert-to-foreign-string
  80    #:allocate-foreign-string
  81    #:with-foreign-string
  82    #:with-foreign-strings
  83    #:foreign-string-length              ; not implemented
  84    #:string-to-octets
  85    #:octets-to-string
  86    #:foreign-encoded-octet-count
  87
  88    ;; function call
  89    #:def-function
  90
  91    ;; libraries
  92    #:find-foreign-library
  93    #:load-foreign-library
  94    #:default-foreign-library-type
  95    #:foreign-library-types
  96
  97    ;; os
  98    #:getenv
  99    #:run-shell-command
 100    ))
 101
 102 (in-package #:cffi-uffi-compat)
 103
 104 #+clisp
 105 (eval-when (:compile-toplevel :load-toplevel :execute)
 106   (when (equal (machine-type) "POWER MACINTOSH")
 107     (pushnew :ppc *features*)))
 108
 109 (defun convert-uffi-type (uffi-type)
 110   "Convert a UFFI primitive type to a CFFI type."
 111   ;; Many CFFI types are the same as UFFI.  This list handles the
 112   ;; exceptions only.
 113   (case uffi-type
 114     (:cstring :pointer)
 115     (:pointer-void :pointer)
 116     (:pointer-self :pointer)
 117     ;; Although UFFI's documentation claims dereferencing :CHAR and
 118     ;; :UNSIGNED-CHAR returns characters, it actually returns
 119     ;; integers.
 120     (:char :char)
 121     (:unsigned-char :unsigned-char)
 122     (:byte :char)
 123     (:unsigned-byte :unsigned-char)
 124     (t
 125      (if (listp uffi-type)
 126          (case (car uffi-type)
 127            ;; this is imho gross but it is what uffi does
 128            (quote (convert-uffi-type (second uffi-type)))
 129            (* :pointer)
 130            (:array `(uffi-array ,(convert-uffi-type (second uffi-type))
 131                                 ,(third uffi-type)))
 132            (:union (second uffi-type))
 133            (:struct (convert-uffi-type (second uffi-type)))
 134            (:struct-pointer :pointer))
 135          uffi-type))))
 136
 137 (cffi:define-foreign-type uffi-array-type ()
 138   ;; ELEMENT-TYPE should be /unparsed/, suitable for passing to mem-aref.
 139   ((element-type :initform (error "An element-type is required.")
 140                  :accessor element-type :initarg :element-type)
 141    (nelems :initform (error "nelems is required.")
 142            :accessor nelems :initarg :nelems))
 143   (:actual-type :pointer)
 144   (:documentation "UFFI's :array type."))
 145
 146 (cffi:define-parse-method uffi-array (element-type count)
 147   (make-instance 'uffi-array-type :element-type element-type
 148                  :nelems (or count 1)))
 149
 150 (defmethod cffi:foreign-type-size ((type uffi-array-type))
 151   (* (cffi:foreign-type-size (element-type type)) (nelems type)))
 152
 153 (defmethod cffi::aggregatep ((type uffi-array-type))
 154   t)
 155
 156 ;; UFFI's :(unsigned-)char
 157 #+#:ignore
 158 (cffi:define-foreign-type uffi-char ()
 159   ())
 160
 161 #+#:ignore
 162 (cffi:define-parse-method uffi-char (base-type)
 163   (make-instance 'uffi-char :actual-type base-type))
 164
 165 #+#:ignore
 166 (defmethod cffi:translate-to-foreign ((value character) (type uffi-char))
 167   (char-code value))
 168
 169 #+#:ignore
 170 (defmethod cffi:translate-from-foreign (obj (type uffi-char))
 171   (code-char obj))
 172
 173 (defmacro def-type (name type)
 174   "Define a Common Lisp type NAME for UFFI type TYPE."
 175   (declare (ignore type))
 176   `(deftype ,name () t))
 177
 178 (defmacro def-foreign-type (name type)
 179   "Define a new foreign type."
 180   `(cffi:defctype ,name ,(convert-uffi-type type)))
 181
 182 (defmacro def-constant (name value &key export)
 183   "Define a constant and conditionally export it."
 184   `(eval-when (:compile-toplevel :load-toplevel :execute)
 185      (defconstant ,name ,value)
 186      ,@(when export `((export ',name)))
 187      ',name))
 188
 189 (defmacro null-char-p (val)
 190   "Return true if character is null."
 191   `(zerop (char-code ,val)))
 192
 193 (defmacro def-enum (enum-name args &key (separator-string "#"))
 194   "Creates a constants for a C type enum list, symbols are
 195 created in the created in the current package. The symbol is the
 196 concatenation of the enum-name name, separator-string, and
 197 field-name"
 198   (let ((counter 0)
 199         (cmds nil)
 200         (constants nil))
 201     (declare (fixnum counter))
 202     (dolist (arg args)
 203       (let ((name (if (listp arg) (car arg) arg))
 204             (value (if (listp arg)
 205                        (prog1
 206                            (setq counter (cadr arg))
 207                          (incf counter))
 208                        (prog1
 209                            counter
 210                          (incf counter)))))
 211         (setq name (intern (concatenate 'string
 212                                         (symbol-name enum-name)
 213                                         separator-string
 214                                         (symbol-name name))))
 215         (push `(def-constant ,name ,value) constants)))
 216     (setf cmds (append '(progn) `((cffi:defctype ,enum-name :int))
 217                        (nreverse constants)))
 218     cmds))
 219
 220 (defmacro def-struct (name &body fields)
 221   "Define a C structure."
 222   `(cffi:defcstruct ,name
 223      ,@(loop for (name uffi-type) in fields
 224              for cffi-type = (convert-uffi-type uffi-type)
 225              collect (list name cffi-type))))
 226
 227 ;; TODO: figure out why the compiler macro is kicking in before
 228 ;; the setf expander.
 229 (defun %foreign-slot-value (obj type field)
 230   (cffi:foreign-slot-value obj `(:struct ,type) field))
 231
 232 (defun (setf %foreign-slot-value) (value obj type field)
 233   (setf (cffi:foreign-slot-value obj `(:struct ,type) field) value))
 234
 235 (defmacro get-slot-value (obj type field)
 236   "Access a slot value from a structure."
 237   `(%foreign-slot-value ,obj ,type ,field))
 238
 239 ;; UFFI uses a different function when accessing a slot whose
 240 ;; type is a pointer. We don't need that in CFFI so we use
 241 ;; foreign-slot-value too.
 242 (defmacro get-slot-pointer (obj type field)
 243   "Access a pointer slot value from a structure."
 244   `(cffi:foreign-slot-value ,obj ,type ,field))
 245
 246 (defmacro def-array-pointer (name type)
 247   "Define a foreign array type."
 248   `(cffi:defctype ,name (uffi-array ,(convert-uffi-type type) 1)))
 249
 250 (defmacro deref-array (array type position)
 251   "Dereference an array."
 252   `(cffi:mem-aref ,array
 253                   ,(if (constantp type)
 254                        `',(element-type (cffi::parse-type
 255                                          (convert-uffi-type (eval type))))
 256                        `(element-type (cffi::parse-type
 257                                        (convert-uffi-type ,type))))
 258                   ,position))
 259
 260 ;; UFFI's documentation on DEF-UNION is a bit scarce, I'm not sure
 261 ;; if DEFCUNION and DEF-UNION are strictly compatible.
 262 (defmacro def-union (name &body fields)
 263   "Define a foreign union type."
 264   `(cffi:defcunion ,name
 265      ,@(loop for (name uffi-type) in fields
 266              for cffi-type = (convert-uffi-type uffi-type)
 267              collect (list name cffi-type))))
 268
 269 (defun convert-uffi-type-form (type-form)
 270   (if (constantp type-form)
 271       `',(convert-uffi-type (eval type-form))
 272       `(convert-uffi-type ,type-form)))
 273
 274 (defmacro allocate-foreign-object (type &optional (size 1))
 275   "Allocate one or more instance of a foreign type."
 276   `(cffi:foreign-alloc ,(convert-uffi-type-form type)
 277                        :count ,size))
 278
 279 (defmacro free-foreign-object (ptr)
 280   "Free a foreign object allocated by ALLOCATE-FOREIGN-OBJECT."
 281   `(cffi:foreign-free ,ptr))
 282
 283 (defmacro with-foreign-object ((var type) &body body)
 284   "Wrap the allocation of a foreign object around BODY."
 285   `(cffi:with-foreign-object (,var ,(convert-uffi-type-form type))
 286      ,@body))
 287
 288 ;; Taken from UFFI's src/objects.lisp
 289 (defmacro with-foreign-objects (bindings &rest body)
 290   (if bindings
 291       `(with-foreign-object ,(car bindings)
 292          (with-foreign-objects ,(cdr bindings)
 293            ,@body))
 294       `(progn ,@body)))
 295
 296 (defmacro size-of-foreign-type (type)
 297   "Return the size in bytes of a foreign type."
 298   `(cffi:foreign-type-size ,(convert-uffi-type-form type)))
 299
 300 (defmacro pointer-address (ptr)
 301   "Return the address of a pointer."
 302   `(cffi:pointer-address ,ptr))
 303
 304 (defmacro deref-pointer (ptr type)
 305   "Dereference a pointer."
 306   `(cffi:mem-ref ,ptr ,(convert-uffi-type-form type)))
 307
 308 (defsetf deref-pointer (ptr type) (value)
 309   `(setf (cffi:mem-ref ,ptr ,(convert-uffi-type-form type)) ,value))
 310
 311 (defmacro ensure-char-character (obj &environment env)
 312   "Convert OBJ to a character if it is an integer."
 313   (if (constantp obj env)
 314       (if (characterp obj) obj (code-char obj))
 315       (let ((obj-var (gensym)))
 316         `(let ((,obj-var ,obj))
 317            (if (characterp ,obj-var)
 318                ,obj-var
 319                (code-char ,obj-var))))))
 320
 321 (defmacro ensure-char-integer (obj &environment env)
 322   "Convert OBJ to an integer if it is a character."
 323   (if (constantp obj env)
 324       (let ((the-obj (eval obj)))
 325         (if (characterp the-obj) (char-code the-obj) the-obj))
 326       (let ((obj-var (gensym)))
 327         `(let ((,obj-var ,obj))
 328            (if (characterp ,obj-var)
 329                (char-code ,obj-var)
 330                ,obj-var)))))
 331
 332 (defmacro ensure-char-storable (obj)
 333   "Ensure OBJ is storable as a character."
 334   `(ensure-char-integer ,obj))
 335
 336 (defmacro make-null-pointer (type)
 337   "Create a NULL pointer."
 338   (declare (ignore type))
 339   `(cffi:null-pointer))
 340
 341 (defmacro make-pointer (address type)
 342   "Create a pointer to ADDRESS."
 343   (declare (ignore type))
 344   `(cffi:make-pointer ,address))
 345
 346 (defmacro null-pointer-p (ptr)
 347   "Return true if PTR is a null pointer."
 348   `(cffi:null-pointer-p ,ptr))
 349
 350 (defparameter +null-cstring-pointer+ (cffi:null-pointer)
 351   "A constant NULL string pointer.")
 352
 353 (defmacro char-array-to-pointer (obj)
 354   obj)
 355
 356 (defmacro with-cast-pointer ((var ptr type) &body body)
 357   "Cast a pointer, does nothing in CFFI."
 358   (declare (ignore type))
 359   `(let ((,var ,ptr))
 360      ,@body))
 361
 362 (defmacro def-foreign-var (name type module)
 363   "Define a symbol macro to access a foreign variable."
 364   (declare (ignore module))
 365   (flet ((lisp-name (name)
 366            (intern (cffi-sys:canonicalize-symbol-name-case
 367                     (substitute #\- #\_ name)))))
 368     `(cffi:defcvar ,(if (listp name)
 369                         name
 370                         (list name (lisp-name name)))
 371          ,(convert-uffi-type type))))
 372
 373 (defmacro def-pointer-var (name value &optional doc)
 374   #-openmcl `(defvar ,name ,value ,@(if doc (list doc)))
 375   #+openmcl `(ccl::defloadvar ,name ,value ,doc))
 376
 377 (defmacro convert-from-cstring (s)
 378   "Convert a cstring to a Lisp string."
 379   (let ((ret (gensym)))
 380     `(let ((,ret (cffi:foreign-string-to-lisp ,s)))
 381        (if (equal ,ret "")
 382            nil
 383            ,ret))))
 384
 385 (defmacro convert-to-cstring (obj)
 386   "Convert a Lisp string to a cstring."
 387   (let ((str (gensym)))
 388     `(let ((,str ,obj))
 389        (if (null ,str)
 390            (cffi:null-pointer)
 391            (cffi:foreign-string-alloc ,str)))))
 392
 393 (defmacro free-cstring (ptr)
 394   "Free a cstring."
 395   `(cffi:foreign-string-free ,ptr))
 396
 397 (defmacro with-cstring ((foreign-string lisp-string) &body body)
 398   "Binds a newly creating string."
 399   (let ((str (gensym)) (body-proc (gensym)))
 400     `(flet ((,body-proc (,foreign-string) ,@body))
 401        (let ((,str ,lisp-string))
 402          (if (null ,str)
 403              (,body-proc (cffi:null-pointer))
 404              (cffi:with-foreign-string (,foreign-string ,str)
 405                (,body-proc ,foreign-string)))))))
 406
 407 ;; Taken from UFFI's src/strings.lisp
 408 (defmacro with-cstrings (bindings &rest body)
 409   (if bindings
 410       `(with-cstring ,(car bindings)
 411          (with-cstrings ,(cdr bindings)
 412            ,@body))
 413       `(progn ,@body)))
 414
 415 (defmacro def-function (name args &key module (returning :void))
 416   "Define a foreign function."
 417   (declare (ignore module))
 418   `(cffi:defcfun ,name ,(convert-uffi-type returning)
 419      ,@(loop for (name type) in args
 420              collect `(,name ,(convert-uffi-type type)))))
 421
 422 ;;; Taken from UFFI's src/libraries.lisp
 423
 424 (defvar *loaded-libraries* nil
 425   "List of foreign libraries loaded. Used to prevent reloading a library")
 426
 427 (defun default-foreign-library-type ()
 428   "Returns string naming default library type for platform"
 429   #+(or win32 cygwin mswindows) "dll"
 430   #+(or macos macosx darwin ccl-5.0) "dylib"
 431   #-(or win32 cygwin mswindows macos macosx darwin ccl-5.0) "so")
 432
 433 (defun foreign-library-types ()
 434   "Returns list of string naming possible library types for platform,
 435 sorted by preference"
 436   #+(or win32 cygwin mswindows) '("dll" "lib" "so")
 437   #+(or macos macosx darwin ccl-5.0) '("dylib" "bundle")
 438   #-(or win32 cygwin mswindows macos macosx darwin ccl-5.0) '("so" "a" "o"))
 439
 440 (defun find-foreign-library (names directories &key types drive-letters)
 441   "Looks for a foreign library. directories can be a single
 442 string or a list of strings of candidate directories. Use default
 443 library type if type is not specified."
 444   (unless types
 445     (setq types (foreign-library-types)))
 446   (unless (listp types)
 447     (setq types (list types)))
 448   (unless (listp names)
 449     (setq names (list names)))
 450   (unless (listp directories)
 451     (setq directories (list directories)))
 452   #+(or win32 mswindows)
 453   (unless (listp drive-letters)
 454     (setq drive-letters (list drive-letters)))
 455   #-(or win32 mswindows)
 456   (setq drive-letters '(nil))
 457   (dolist (drive-letter drive-letters)
 458     (dolist (name names)
 459       (dolist (dir directories)
 460    (dolist (type types)
 461      (let ((path (make-pathname
 462              #+lispworks :host
 463              #+lispworks (when drive-letter drive-letter)
 464              #-lispworks :device
 465              #-lispworks (when drive-letter drive-letter)
 466              :name name
 467              :type type
 468              :directory
 469              (etypecase dir
 470           (pathname
 471            (pathname-directory dir))
 472           (list
 473            dir)
 474           (string
 475            (pathname-directory
 476             (parse-namestring dir)))))))
 477        (when (probe-file path)
 478          (return-from find-foreign-library path)))))))
 479   nil)
 480
 481 (defun convert-supporting-libraries-to-string (libs)
 482   (let (lib-load-list)
 483     (dolist (lib libs)
 484       (push (format nil "-l~A" lib) lib-load-list))
 485     (nreverse lib-load-list)))
 486
 487 (defun load-foreign-library (filename &key module supporting-libraries
 488                              force-load)
 489   #+(or allegro mcl sbcl clisp) (declare (ignore module supporting-libraries))
 490   #+(or cmucl scl sbcl) (declare (ignore module))
 491
 492   (when (and filename (or (null (pathname-directory filename))
 493                           (probe-file filename)))
 494     (if (pathnamep filename) ;; ensure filename is a string to check if
 495    (setq filename (namestring filename))) ; already loaded
 496
 497     (if (and (not force-load)
 498         (find filename *loaded-libraries* :test #'string-equal))
 499         t ;; return T, but don't reload library
 500         (progn
 501           ;; FIXME: Hmm, what are these two for?
 502           #+cmucl
 503           (let ((type (pathname-type (parse-namestring filename))))
 504             (if (string-equal type "so")
 505                 (sys::load-object-file filename)
 506                 (alien:load-foreign filename
 507                                     :libraries
 508                                     (convert-supporting-libraries-to-string
 509                                      supporting-libraries))))
 510           #+scl
 511           (let ((type (pathname-type (parse-namestring filename))))
 512             (if (string-equal type "so")
 513                 (sys::load-dynamic-object filename)
 514                 (alien:load-foreign filename
 515                                     :libraries
 516                                     (convert-supporting-libraries-to-string
 517                                      supporting-libraries))))
 518
 519           #-(or cmucl scl)
 520           (cffi:load-foreign-library filename)
 521           (push filename *loaded-libraries*)
 522           t))))
 523
 524 ;; Taken from UFFI's src/os.lisp
 525 (defun getenv (var)
 526   "Return the value of the environment variable."
 527   #+allegro (sys::getenv (string var))
 528   #+clisp (sys::getenv (string var))
 529   #+(or cmucl scl) (cdr (assoc (string var) ext:*environment-list* :test #'equalp
 530                              :key #'string))
 531   #+(or ecl gcl) (si:getenv (string var))
 532   #+lispworks (lw:environment-variable (string var))
 533   #+lucid (lcl:environment-variable (string var))
 534   #+(or mcl ccl) (ccl::getenv var)
 535   #+sbcl (sb-ext:posix-getenv var)
 536   #-(or allegro clisp cmucl ecl scl gcl lispworks lucid mcl ccl sbcl)
 537   (error 'not-implemented :proc (list 'getenv var)))
 538
 539 ;; Taken from UFFI's src/os.lisp
 540 ;; modified from function ASDF -- Copyright Dan Barlow and Contributors
 541 (defun run-shell-command (control-string &rest args)
 542   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 543 synchronously execute the result using a Bourne-compatible shell, with
 544 output to *trace-output*.  Returns the shell's exit code."
 545   (let ((command (apply #'format nil control-string args))
 546         (output *trace-output*))
 547     #+sbcl
 548     (sb-impl::process-exit-code
 549      (sb-ext:run-program
 550       "/bin/sh"
 551       (list "-c" command)
 552       :input nil :output output))
 553
 554     #+(or cmucl scl)
 555     (ext:process-exit-code
 556      (ext:run-program
 557       "/bin/sh"
 558       (list "-c" command)
 559       :input nil :output output))
 560
 561     #+allegro
 562     (excl:run-shell-command command :input nil :output output)
 563
 564     #+lispworks
 565     (system:call-system-showing-output
 566      command
 567      :shell-type "/bin/sh"
 568      :output-stream output)
 569
 570     #+clisp             ;XXX not exactly *trace-output*, I know
 571     (ext:run-shell-command  command :output :terminal :wait t)
 572
 573     #+openmcl
 574     (nth-value 1
 575            (ccl:external-process-status
 576         (ccl:run-program "/bin/sh" (list "-c" command)
 577                  :input nil :output output
 578                  :wait t)))
 579
 580     #+ecl
 581     (nth-value 1
 582                (ext:run-program
 583                 "/bin/sh" (list "-c" command)
 584                 :input nil :output output :error nil :wait t))
 585
 586     #-(or openmcl ecl clisp lispworks allegro scl cmucl sbcl)
 587     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
 588     ))
 589
 590 ;;; Some undocumented UFFI operators...
 591
 592 (defmacro convert-from-foreign-string
 593     (obj &key length (locale :default)
 594      (encoding 'cffi:*default-foreign-encoding*)
 595      (null-terminated-p t))
 596   ;; in effect, (eq NULL-TERMINATED-P (null LENGTH)). Hopefully,
 597   ;; that's compatible with the intended semantics, which are
 598   ;; undocumented.  If that's not the case, we can implement
 599   ;; NULL-TERMINATED-P in CFFI:FOREIGN-STRING-TO-LISP.
 600   (declare (ignore locale null-terminated-p))
 601   (let ((ret (gensym)))
 602     `(let ((,ret (cffi:foreign-string-to-lisp ,obj
 603                                               :count ,length
 604                                               :encoding ,encoding)))
 605        (if (equal ,ret "")
 606            nil
 607            ,ret))))
 608
 609 ;; What's the difference between this and convert-to-cstring?
 610 (defmacro convert-to-foreign-string
 611     (obj &optional (encoding 'cffi:*default-foreign-encoding*))
 612   (let ((str (gensym)))
 613     `(let ((,str ,obj))
 614        (if (null ,str)
 615            (cffi:null-pointer)
 616            (cffi:foreign-string-alloc ,str :encoding ,encoding)))))
 617
 618 (defmacro allocate-foreign-string (size &key unsigned)
 619   (declare (ignore unsigned))
 620   `(cffi:foreign-alloc :char :count ,size))
 621
 622 ;; Ditto.
 623 (defmacro with-foreign-string ((foreign-string lisp-string) &body body)
 624   (let ((str (gensym)))
 625     `(let ((,str ,lisp-string))
 626        (if (null ,str)
 627            (let ((,foreign-string (cffi:null-pointer)))
 628              ,@body)
 629            (cffi:with-foreign-string (,foreign-string ,str)
 630              ,@body)))))
 631
 632 (defmacro with-foreign-strings (bindings &body body)
 633   `(with-foreign-string ,(car bindings)
 634     ,@(if (cdr bindings)
 635           `((with-foreign-strings ,(cdr bindings) ,@body))
 636           body)))
 637
 638 ;; This function returns a form? Where is this used in user-code?
 639 (defun foreign-string-length (foreign-string)
 640   (declare (ignore foreign-string))
 641   (error "FOREIGN-STRING-LENGTH not implemented."))
 642
 643 ;; This should be optimized.
 644 (defun convert-from-foreign-usb8 (s len)
 645   (let ((a (make-array len :element-type '(unsigned-byte 8))))
 646     (dotimes (i len a)
 647       (setf (aref a i) (cffi:mem-ref s :unsigned-char i)))))
 648
 649 ;;;; String Encodings
 650
 651 (defmacro string-to-octets (str &key encoding null-terminate)
 652   `(babel:concatenate-strings-to-octets
 653     (or ,encoding cffi:*default-foreign-encoding*)
 654     ,str
 655     (if ,null-terminate
 656         #.(string #\Nul)
 657         "")))
 658
 659 (defmacro octets-to-string (octets &key encoding)
 660   `(babel:octets-to-string ,octets
 661                            :encoding (or ,encoding
 662                                          cffi:*default-foreign-encoding*)))
 663
 664 (defun foreign-encoded-octet-count (str &key encoding)
 665   (babel:string-size-in-octets str
 666                                :encoding (or encoding
 667                                              cffi:*default-foreign-encoding*)))