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 (defmacro allocate-foreign-object (type &optional (size 1))
 270   "Allocate one or more instance of a foreign type."
 271   `(cffi:foreign-alloc ,(if (constantp type)
 272                             `',(convert-uffi-type (eval type))
 273                             `(convert-uffi-type ,type))
 274                        :count ,size))
 275
 276 (defmacro free-foreign-object (ptr)
 277   "Free a foreign object allocated by ALLOCATE-FOREIGN-OBJECT."
 278   `(cffi:foreign-free ,ptr))
 279
 280 (defmacro with-foreign-object ((var type) &body body)
 281   "Wrap the allocation of a foreign object around BODY."
 282   `(cffi:with-foreign-object (,var (convert-uffi-type ,type))
 283      ,@body))
 284
 285 ;; Taken from UFFI's src/objects.lisp
 286 (defmacro with-foreign-objects (bindings &rest body)
 287   (if bindings
 288       `(with-foreign-object ,(car bindings)
 289          (with-foreign-objects ,(cdr bindings)
 290            ,@body))
 291       `(progn ,@body)))
 292
 293 (defmacro size-of-foreign-type (type)
 294   "Return the size in bytes of a foreign type."
 295   `(cffi:foreign-type-size (convert-uffi-type ,type)))
 296
 297 (defmacro pointer-address (ptr)
 298   "Return the address of a pointer."
 299   `(cffi:pointer-address ,ptr))
 300
 301 (defmacro deref-pointer (ptr type)
 302   "Dereference a pointer."
 303   `(cffi:mem-ref ,ptr (convert-uffi-type ,type)))
 304
 305 (defsetf deref-pointer (ptr type) (value)
 306   `(setf (cffi:mem-ref ,ptr (convert-uffi-type ,type)) ,value))
 307
 308 (defmacro ensure-char-character (obj &environment env)
 309   "Convert OBJ to a character if it is an integer."
 310   (if (constantp obj env)
 311       (if (characterp obj) obj (code-char obj))
 312       (let ((obj-var (gensym)))
 313         `(let ((,obj-var ,obj))
 314            (if (characterp ,obj-var)
 315                ,obj-var
 316                (code-char ,obj-var))))))
 317
 318 (defmacro ensure-char-integer (obj &environment env)
 319   "Convert OBJ to an integer if it is a character."
 320   (if (constantp obj env)
 321       (let ((the-obj (eval obj)))
 322         (if (characterp the-obj) (char-code the-obj) the-obj))
 323       (let ((obj-var (gensym)))
 324         `(let ((,obj-var ,obj))
 325            (if (characterp ,obj-var)
 326                (char-code ,obj-var)
 327                ,obj-var)))))
 328
 329 (defmacro ensure-char-storable (obj)
 330   "Ensure OBJ is storable as a character."
 331   `(ensure-char-integer ,obj))
 332
 333 (defmacro make-null-pointer (type)
 334   "Create a NULL pointer."
 335   (declare (ignore type))
 336   `(cffi:null-pointer))
 337
 338 (defmacro make-pointer (address type)
 339   "Create a pointer to ADDRESS."
 340   (declare (ignore type))
 341   `(cffi:make-pointer ,address))
 342
 343 (defmacro null-pointer-p (ptr)
 344   "Return true if PTR is a null pointer."
 345   `(cffi:null-pointer-p ,ptr))
 346
 347 (defparameter +null-cstring-pointer+ (cffi:null-pointer)
 348   "A constant NULL string pointer.")
 349
 350 (defmacro char-array-to-pointer (obj)
 351   obj)
 352
 353 (defmacro with-cast-pointer ((var ptr type) &body body)
 354   "Cast a pointer, does nothing in CFFI."
 355   (declare (ignore type))
 356   `(let ((,var ,ptr))
 357      ,@body))
 358
 359 (defmacro def-foreign-var (name type module)
 360   "Define a symbol macro to access a foreign variable."
 361   (declare (ignore module))
 362   (flet ((lisp-name (name)
 363            (intern (cffi-sys:canonicalize-symbol-name-case
 364                     (substitute #\- #\_ name)))))
 365     `(cffi:defcvar ,(if (listp name)
 366                         name
 367                         (list name (lisp-name name)))
 368          ,(convert-uffi-type type))))
 369
 370 (defmacro def-pointer-var (name value &optional doc)
 371   #-openmcl `(defvar ,name ,value ,@(if doc (list doc)))
 372   #+openmcl `(ccl::defloadvar ,name ,value ,doc))
 373
 374 (defmacro convert-from-cstring (s)
 375   "Convert a cstring to a Lisp string."
 376   (let ((ret (gensym)))
 377     `(let ((,ret (cffi:foreign-string-to-lisp ,s)))
 378        (if (equal ,ret "")
 379            nil
 380            ,ret))))
 381
 382 (defmacro convert-to-cstring (obj)
 383   "Convert a Lisp string to a cstring."
 384   (let ((str (gensym)))
 385     `(let ((,str ,obj))
 386        (if (null ,str)
 387            (cffi:null-pointer)
 388            (cffi:foreign-string-alloc ,str)))))
 389
 390 (defmacro free-cstring (ptr)
 391   "Free a cstring."
 392   `(cffi:foreign-string-free ,ptr))
 393
 394 (defmacro with-cstring ((foreign-string lisp-string) &body body)
 395   "Binds a newly creating string."
 396   (let ((str (gensym)) (body-proc (gensym)))
 397     `(flet ((,body-proc (,foreign-string) ,@body))
 398        (let ((,str ,lisp-string))
 399          (if (null ,str)
 400              (,body-proc (cffi:null-pointer))
 401              (cffi:with-foreign-string (,foreign-string ,str)
 402                (,body-proc ,foreign-string)))))))
 403
 404 ;; Taken from UFFI's src/strings.lisp
 405 (defmacro with-cstrings (bindings &rest body)
 406   (if bindings
 407       `(with-cstring ,(car bindings)
 408          (with-cstrings ,(cdr bindings)
 409            ,@body))
 410       `(progn ,@body)))
 411
 412 (defmacro def-function (name args &key module (returning :void))
 413   "Define a foreign function."
 414   (declare (ignore module))
 415   `(cffi:defcfun ,name ,(convert-uffi-type returning)
 416      ,@(loop for (name type) in args
 417              collect `(,name ,(convert-uffi-type type)))))
 418
 419 ;;; Taken from UFFI's src/libraries.lisp
 420
 421 (defvar *loaded-libraries* nil
 422   "List of foreign libraries loaded. Used to prevent reloading a library")
 423
 424 (defun default-foreign-library-type ()
 425   "Returns string naming default library type for platform"
 426   #+(or win32 cygwin mswindows) "dll"
 427   #+(or macos macosx darwin ccl-5.0) "dylib"
 428   #-(or win32 cygwin mswindows macos macosx darwin ccl-5.0) "so")
 429
 430 (defun foreign-library-types ()
 431   "Returns list of string naming possible library types for platform,
 432 sorted by preference"
 433   #+(or win32 cygwin mswindows) '("dll" "lib" "so")
 434   #+(or macos macosx darwin ccl-5.0) '("dylib" "bundle")
 435   #-(or win32 cygwin mswindows macos macosx darwin ccl-5.0) '("so" "a" "o"))
 436
 437 (defun find-foreign-library (names directories &key types drive-letters)
 438   "Looks for a foreign library. directories can be a single
 439 string or a list of strings of candidate directories. Use default
 440 library type if type is not specified."
 441   (unless types
 442     (setq types (foreign-library-types)))
 443   (unless (listp types)
 444     (setq types (list types)))
 445   (unless (listp names)
 446     (setq names (list names)))
 447   (unless (listp directories)
 448     (setq directories (list directories)))
 449   #+(or win32 mswindows)
 450   (unless (listp drive-letters)
 451     (setq drive-letters (list drive-letters)))
 452   #-(or win32 mswindows)
 453   (setq drive-letters '(nil))
 454   (dolist (drive-letter drive-letters)
 455     (dolist (name names)
 456       (dolist (dir directories)
 457    (dolist (type types)
 458      (let ((path (make-pathname
 459              #+lispworks :host
 460              #+lispworks (when drive-letter drive-letter)
 461              #-lispworks :device
 462              #-lispworks (when drive-letter drive-letter)
 463              :name name
 464              :type type
 465              :directory
 466              (etypecase dir
 467           (pathname
 468            (pathname-directory dir))
 469           (list
 470            dir)
 471           (string
 472            (pathname-directory
 473             (parse-namestring dir)))))))
 474        (when (probe-file path)
 475          (return-from find-foreign-library path)))))))
 476   nil)
 477
 478 (defun convert-supporting-libraries-to-string (libs)
 479   (let (lib-load-list)
 480     (dolist (lib libs)
 481       (push (format nil "-l~A" lib) lib-load-list))
 482     (nreverse lib-load-list)))
 483
 484 (defun load-foreign-library (filename &key module supporting-libraries
 485                              force-load)
 486   #+(or allegro mcl sbcl clisp) (declare (ignore module supporting-libraries))
 487   #+(or cmucl scl sbcl) (declare (ignore module))
 488
 489   (when (and filename (or (null (pathname-directory filename))
 490                           (probe-file filename)))
 491     (if (pathnamep filename) ;; ensure filename is a string to check if
 492    (setq filename (namestring filename))) ; already loaded
 493
 494     (if (and (not force-load)
 495         (find filename *loaded-libraries* :test #'string-equal))
 496         t ;; return T, but don't reload library
 497         (progn
 498           ;; FIXME: Hmm, what are these two for?
 499           #+cmucl
 500           (let ((type (pathname-type (parse-namestring filename))))
 501             (if (string-equal type "so")
 502                 (sys::load-object-file filename)
 503                 (alien:load-foreign filename
 504                                     :libraries
 505                                     (convert-supporting-libraries-to-string
 506                                      supporting-libraries))))
 507           #+scl
 508           (let ((type (pathname-type (parse-namestring filename))))
 509             (if (string-equal type "so")
 510                 (sys::load-dynamic-object filename)
 511                 (alien:load-foreign filename
 512                                     :libraries
 513                                     (convert-supporting-libraries-to-string
 514                                      supporting-libraries))))
 515
 516           #-(or cmucl scl)
 517           (cffi:load-foreign-library filename)
 518           (push filename *loaded-libraries*)
 519           t))))
 520
 521 ;; Taken from UFFI's src/os.lisp
 522 (defun getenv (var)
 523   "Return the value of the environment variable."
 524   #+allegro (sys::getenv (string var))
 525   #+clisp (sys::getenv (string var))
 526   #+(or cmucl scl) (cdr (assoc (string var) ext:*environment-list* :test #'equalp
 527                              :key #'string))
 528   #+(or ecl gcl) (si:getenv (string var))
 529   #+lispworks (lw:environment-variable (string var))
 530   #+lucid (lcl:environment-variable (string var))
 531   #+(or mcl ccl) (ccl::getenv var)
 532   #+sbcl (sb-ext:posix-getenv var)
 533   #-(or allegro clisp cmucl ecl scl gcl lispworks lucid mcl ccl sbcl)
 534   (error 'not-implemented :proc (list 'getenv var)))
 535
 536 ;; Taken from UFFI's src/os.lisp
 537 ;; modified from function ASDF -- Copyright Dan Barlow and Contributors
 538 (defun run-shell-command (control-string &rest args)
 539   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 540 synchronously execute the result using a Bourne-compatible shell, with
 541 output to *trace-output*.  Returns the shell's exit code."
 542   (let ((command (apply #'format nil control-string args))
 543         (output *trace-output*))
 544     #+sbcl
 545     (sb-impl::process-exit-code
 546      (sb-ext:run-program
 547       "/bin/sh"
 548       (list "-c" command)
 549       :input nil :output output))
 550
 551     #+(or cmucl scl)
 552     (ext:process-exit-code
 553      (ext:run-program
 554       "/bin/sh"
 555       (list "-c" command)
 556       :input nil :output output))
 557
 558     #+allegro
 559     (excl:run-shell-command command :input nil :output output)
 560
 561     #+lispworks
 562     (system:call-system-showing-output
 563      command
 564      :shell-type "/bin/sh"
 565      :output-stream output)
 566
 567     #+clisp             ;XXX not exactly *trace-output*, I know
 568     (ext:run-shell-command  command :output :terminal :wait t)
 569
 570     #+openmcl
 571     (nth-value 1
 572            (ccl:external-process-status
 573         (ccl:run-program "/bin/sh" (list "-c" command)
 574                  :input nil :output output
 575                  :wait t)))
 576
 577     #+ecl
 578     (nth-value 1
 579                (ext:run-program
 580                 "/bin/sh" (list "-c" command)
 581                 :input nil :output output :error nil :wait t))
 582
 583     #-(or openmcl ecl clisp lispworks allegro scl cmucl sbcl)
 584     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
 585     ))
 586
 587 ;;; Some undocumented UFFI operators...
 588
 589 (defmacro convert-from-foreign-string
 590     (obj &key length (locale :default)
 591      (encoding 'cffi:*default-foreign-encoding*)
 592      (null-terminated-p t))
 593   ;; in effect, (eq NULL-TERMINATED-P (null LENGTH)). Hopefully,
 594   ;; that's compatible with the intended semantics, which are
 595   ;; undocumented.  If that's not the case, we can implement
 596   ;; NULL-TERMINATED-P in CFFI:FOREIGN-STRING-TO-LISP.
 597   (declare (ignore locale null-terminated-p))
 598   (let ((ret (gensym)))
 599     `(let ((,ret (cffi:foreign-string-to-lisp ,obj
 600                                               :count ,length
 601                                               :encoding ,encoding)))
 602        (if (equal ,ret "")
 603            nil
 604            ,ret))))
 605
 606 ;; What's the difference between this and convert-to-cstring?
 607 (defmacro convert-to-foreign-string
 608     (obj &optional (encoding 'cffi:*default-foreign-encoding*))
 609   (let ((str (gensym)))
 610     `(let ((,str ,obj))
 611        (if (null ,str)
 612            (cffi:null-pointer)
 613            (cffi:foreign-string-alloc ,str :encoding ,encoding)))))
 614
 615 (defmacro allocate-foreign-string (size &key unsigned)
 616   (declare (ignore unsigned))
 617   `(cffi:foreign-alloc :char :count ,size))
 618
 619 ;; Ditto.
 620 (defmacro with-foreign-string ((foreign-string lisp-string) &body body)
 621   (let ((str (gensym)))
 622     `(let ((,str ,lisp-string))
 623        (if (null ,str)
 624            (let ((,foreign-string (cffi:null-pointer)))
 625              ,@body)
 626            (cffi:with-foreign-string (,foreign-string ,str)
 627              ,@body)))))
 628
 629 (defmacro with-foreign-strings (bindings &body body)
 630   `(with-foreign-string ,(car bindings)
 631     ,@(if (cdr bindings)
 632           `((with-foreign-strings ,(cdr bindings) ,@body))
 633           body)))
 634
 635 ;; This function returns a form? Where is this used in user-code?
 636 (defun foreign-string-length (foreign-string)
 637   (declare (ignore foreign-string))
 638   (error "FOREIGN-STRING-LENGTH not implemented."))
 639
 640 ;; This should be optimized.
 641 (defun convert-from-foreign-usb8 (s len)
 642   (let ((a (make-array len :element-type '(unsigned-byte 8))))
 643     (dotimes (i len a)
 644       (setf (aref a i) (cffi:mem-ref s :unsigned-char i)))))
 645
 646 ;;;; String Encodings
 647
 648 (defmacro string-to-octets (str &key encoding null-terminate)
 649   `(babel:concatenate-strings-to-octets
 650     (or ,encoding cffi:*default-foreign-encoding*)
 651     ,str
 652     (if ,null-terminate
 653         #.(string #\Nul)
 654         "")))
 655
 656 (defmacro octets-to-string (octets &key encoding)
 657   `(babel:octets-to-string ,octets
 658                            :encoding (or ,encoding
 659                                          cffi:*default-foreign-encoding*)))
 660
 661 (defun foreign-encoded-octet-count (str &key encoding)
 662   (babel:string-size-in-octets str
 663                                :encoding (or encoding
 664                                              cffi:*default-foreign-encoding*)))