uffi-compat.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
uffi-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 <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*)))