GopherProxy

	tuffi-compat.lisp - clic - Clic is an command line interactive client for gophe…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tuffi-compat.lisp (22648B)
	---
	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 <[email protected]>
	6 ;;; Copyright (C) 2005-2007, Luis Oliveira <[email protected]>
	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" "…
	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-libra…
	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-str…
	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-str…
	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…
	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-encod…