1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: strings.lisp
6 ;;;; Purpose: UFFI source to handle strings, cstrings, and foreigns
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Feb 2002
10 ;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
11 ;;;; *************************************************************************
16 (def-pointer-var +null-cstring-pointer+
17 #+(or cmu sbcl scl) nil
19 #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
20 #+(or openmcl digitool) (ccl:%null-ptr)
23 (defmacro convert-from-cstring (obj)
24 "Converts a string from a c-call. Same as convert-from-foreign-string, except
25 that LW/CMU automatically converts strings from c-calls."
26 #+(or cmu sbcl lispworks scl) obj
28 (let ((stored (gensym)))
29 `(let ((,stored ,obj))
32 (values (excl:native-to-string ,stored)))))
33 #+(or openmcl digitool)
34 (let ((stored (gensym)))
35 `(let ((,stored ,obj))
36 (if (ccl:%null-ptr-p ,stored)
38 (values (ccl:%get-cstring ,stored)))))
41 (defmacro convert-to-cstring (obj)
42 #+(or cmu sbcl scl lispworks) obj
44 (let ((stored (gensym)))
45 `(let ((,stored ,obj))
48 (values (excl:string-to-native ,stored)))))
49 #+(or openmcl digitool)
50 (let ((stored (gensym)))
51 `(let ((,stored ,obj))
53 +null-cstring-pointer+
54 (let ((ptr (new-ptr (1+ (length ,stored)))))
55 (ccl::%put-cstring ptr ,stored)
59 (defmacro free-cstring (obj)
60 #+(or cmu sbcl scl lispworks) (declare (ignore obj))
62 (let ((stored (gensym)))
63 `(let ((,stored ,obj))
64 (unless (zerop ,stored)
65 (ff:free-fobject ,stored))))
66 #+(or openmcl digitool)
67 (let ((stored (gensym)))
68 `(let ((,stored ,obj))
69 (unless (ccl:%null-ptr-p ,stored)
70 (dispose-ptr ,stored))))
73 (defmacro with-cstring ((cstring lisp-string) &body body)
74 #+(or cmu sbcl scl lispworks)
75 `(let ((,cstring ,lisp-string)) ,@body)
77 (let ((acl-native (gensym))
78 (stored-lisp-string (gensym)))
79 `(let ((,stored-lisp-string ,lisp-string))
80 (excl:with-native-string (,acl-native ,stored-lisp-string)
81 (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
83 #+(or openmcl digitool)
84 (let ((stored-lisp-string (gensym)))
85 `(let ((,stored-lisp-string ,lisp-string))
86 (if (stringp ,stored-lisp-string)
87 (ccl:with-cstrs ((,cstring ,stored-lisp-string))
89 (let ((,cstring +null-cstring-pointer+))
93 (defmacro with-cstrings (bindings &rest body)
95 `(with-cstring ,(car bindings)
96 (with-cstrings ,(cdr bindings)
100 ;;; Foreign string functions
102 (defun %convert-to-foreign-string (str foreign-encoding)
106 (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
109 (declare (optimize (speed 3) (safety 0)))
110 (let* ((size (length str))
111 (storage (alien:make-alien (alien:unsigned 8) (1+ size))))
112 (declare (fixnum size))
113 (setq storage (alien:cast storage (* (alien:unsigned 8))))
116 (setf (alien:deref storage i)
117 (char-code (char stored-obj i))))
118 (setf (alien:deref storage size) 0))
121 #+(and sbcl (not sb-unicode))
122 (etypecase stored-obj
124 (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
127 (declare (optimize (speed 3) (safety 0)))
128 (let* ((size (length stored-obj))
129 (storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ size))))
131 (setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8))))
134 (setf (sb-alien:deref storage i)
135 (char-code (char stored-obj i))))
136 (setf (sb-alien:deref storage size) 0))
139 #+(and sbcl sb-unicode)
142 (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
145 (declare (optimize (speed 3) (safety 0)))
146 (let* ((fe (or foreign-encoding *default-foreign-encoding*))
147 (ife (when fe (implementation-foreign-encoding fe))))
149 (let* ((octets (sb-ext:string-to-octets str :external-format ife))
150 (size (length octets))
151 (storage (sb-alien:make-alien (sb-alien:unsigned 8) (+ size 2))))
152 (declare (fixnum size))
153 (setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8))))
156 (setf (sb-alien:deref storage i) (svref octets i)))
157 ;; terminate with 2 nulls, maybe needed for some encodings
158 (setf (sb-alien:deref storage size) 0)
159 (setf (sb-alien:deref storage (1+ size)) 0)
162 (let* ((size (length str))
163 (storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ size))))
164 (declare (fixnum size))
165 (setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8))))
168 (setf (sb-alien:deref storage i)
169 (char-code (char stored-obj i))))
170 (setf (sb-alien:deref storage size) 0)
173 #+(and openmcl openmcl-unicode-strings)
175 +null-cstring-pointer+
177 (declare (optimize (speed 3) (safety 0)))
178 (let* ((fe (or foreign-encoding *default-foreign-encoding*))
179 (ife (when fe (implementation-foreign-encoding fe))))
181 (let* ((octets (ccl:encode-string-to-octets str :external-format ife))
182 (size (length octets))
183 (ptr (new-ptr (+ size 2))))
184 (declare (fixnum size))
187 (setf (ccl:%get-unsigned-byte ptr i) (svref octets i)))
188 (setf (ccl:%get-unsigned-byte ptr size) 0)
189 (setf (ccl:%get-unsigned-byte ptr (1+ size)) 0)
192 (let ((ptr (new-ptr (1+ (length str)))))
193 (ccl::%put-cstring ptr str)
196 #+(or digitool (and openmcl (not openmcl-unicode-strings)))
198 +null-cstring-pointer+
199 (let ((ptr (new-ptr (1+ (length str)))))
200 (ccl::%put-cstring ptr str)
203 #+(or allegro lispworks)
204 (declare (ignore str foreign-encoding))
208 (defmacro convert-to-foreign-string (obj &optional foreign-encoding)
210 (let ((stored (gensym "STR-"))
212 (ife (gensym "IFE-")))
213 `(let* ((,stored ,obj)
214 (,fe (or foreign-encoding *default-foreign-encoding*))
216 (implementation-foreign-encoding ,fe))))
221 (values (excl:string-to-native ,stored)))
223 (values (excl:string-to-native ,stored :external-format ,ife))))))
226 (let ((stored (gensym "STR-"))
228 (ife (gensym "NEF-")))
229 `(let* ((,stored ,obj)
230 (,fe (or ,foreign-encoding *default-foreign-encoding*))
232 (implementation-foreign-encoding ,fe))))
235 +null-cstring-pointer+)
237 (fli:convert-to-foreign-string ,stored))
239 (fli:convert-to-foreign-string ,stored :external-format ,ife)))))
241 #+(or cmu scl sbcl digitool openmcl)
242 `(%convert-to-foreign-string ,obj (implementation-foreign-encoding
243 (or ,foreign-encoding *default-foreign-encoding*)))
247 ;; Either length or null-terminated-p must be non-nil
248 (defmacro convert-from-foreign-string (obj &key
251 (null-terminated-p t))
253 (let ((stored-obj (gensym "STR-"))
255 (ife (gensym "IFE-")))
256 `(let ((,stored-obj ,obj))
257 (if (zerop ,stored-obj)
259 (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*))
260 (,ife (when ,fe (implementation-foreign-encoding ,fe))))
263 (excl:native-to-string
265 ,@(when length (list :length length))
266 :truncate (not ,null-terminated-p)
267 :external-format ,ife))
268 (fast-native-to-string ,stored-obj ,length))))))
271 ;; FAST-NATIVE-TO-STRING (suprisingly) works just fine with UTF-8 multibyte character strings
272 ;; However, without knowledge of specific-encoding, the LENGTH call in FAST-NATIVE-TO-STRING
273 ;; may not be incorrect for some encodings/strings.
274 ;; This is a stop-gap until get tech support on why the below fails.
275 (let ((stored-obj (gensym "STR-")))
276 `(let ((,stored-obj ,obj))
277 (if (fli:null-pointer-p ,stored-obj)
279 (fast-native-to-string ,stored-obj ,length))))
280 ;; Below code doesn't work on tesing with LW 6.0 testing with a UTF-8 string.
281 ;; fli:convert-from-foreign-string with :external-format of :UTF-8 doesn't
282 ;; properly code multibyte characters.
284 (let ((stored-obj (gensym "STR-"))
286 (ife (gensym "IFE-")))
287 `(let ((,stored-obj ,obj))
288 (if (fli:null-pointer-p ,stored-obj)
290 (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*))
291 (,ife (when ,fe (implementation-foreign-encoding ,fe))))
293 (fli:convert-from-foreign-string
295 ,@(when length (list :length length))
296 :null-terminated-p ,null-terminated-p
297 :external-format (list ,ife :eol-style :lf))
298 (fast-native-to-string ,stored-obj ,length))))))
302 (let ((stored-obj (gensym)))
303 `(let ((,stored-obj ,obj))
304 (if (null-pointer-p ,stored-obj)
306 (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj)
308 :null-terminated-p ,null-terminated-p))))
309 #+(and sbcl (not sb-unicode))
310 (let ((stored-obj (gensym)))
311 `(let ((,stored-obj ,obj))
312 (if (null-pointer-p ,stored-obj)
314 (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
316 :null-terminated-p ,null-terminated-p))))
318 #+(and sbcl sb-unicode)
319 (let ((stored-obj (gensym "STR-"))
321 (ife (gensym "IFE-")))
322 `(let ((,stored-obj ,obj))
323 (if (null-pointer-p ,stored-obj)
325 (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*))
326 (,ife (when ,fe (implementation-foreign-encoding ,fe))))
327 (sb-alien::c-string-to-string (sb-alien:alien-sap ,stored-obj)
328 (or ,ife sb-impl::*default-external-format* :latin-1)
331 #+(or openmcl digitool)
332 (declare (ignore null-terminated-p))
333 #+(or openmcl digitool)
334 (let ((stored-obj (gensym "STR-"))
336 `(let ((,stored-obj ,obj))
337 (if (ccl:%null-ptr-p ,stored-obj)
342 ,@(if length (list length) nil))
344 (let ((,fe (or ,foreign-encoding *default-foreign-encoding*)))
347 (ccl::%get-utf-8-cstring ,stored-obj))
349 (ccl::%get-native-utf-16-cstring ,stored-obj))
352 `((ccl:%str-from-ptr ,stored-obj ,length))
353 `((ccl:%get-cstring ,stored-obj)))))))))
357 (defmacro allocate-foreign-string (size &key (unsigned t))
359 (let ((array-def (gensym)))
360 `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
361 (eval `(alien:cast (alien:make-alien ,,array-def)
363 '(* (alien:unsigned 8))
364 '(* (alien:signed 8)))))))
367 `(alien:make-alien ,(if unsigned
373 `(sb-alien:make-alien ,(if unsigned
374 '(sb-alien:unsigned 8)
375 '(sb-alien:signed 8))
379 `(fli:allocate-foreign-object :type
385 (declare (ignore unsigned))
387 `(ff:allocate-fobject :char :c ,size)
388 #+(or openmcl digitool)
389 (declare (ignore unsigned))
390 #+(or openmcl digitool)
394 (defun foreign-string-length (foreign-string)
395 #+allegro `(ff:foreign-strlen ,foreign-string)
398 until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
400 finally return size))
403 (defmacro with-foreign-string ((foreign-string lisp-string &optional foreign-encoding)
405 (let ((result (gensym))
407 `(let* ((,fe ,foreign-encoding)
408 (,foreign-string (convert-to-foreign-string ,lisp-string ,fe))
409 (,result (progn ,@body)))
410 (declare (dynamic-extent ,foreign-string))
411 (free-foreign-object ,foreign-string)
414 (defmacro with-foreign-strings (bindings &body body)
415 `(with-foreign-string ,(car bindings)
417 `((with-foreign-strings ,(cdr bindings) ,@body))
420 ;; Modified from CMUCL's source to handle non-null terminated strings
422 (defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
423 (declare (type system:system-area-pointer sap))
425 (declare (optimize (speed 3) (safety 0)))
426 (let ((null-terminated-length
427 (when null-terminated-p
429 for offset of-type fixnum upfrom 0
430 until (zerop (system:sap-ref-8 sap offset))
431 finally (return offset)))))
433 (if (and null-terminated-length
434 (> (the fixnum length) (the fixnum null-terminated-length)))
435 (setq length null-terminated-length))
436 (setq length null-terminated-length)))
437 (let ((result (make-string length)))
438 (kernel:copy-from-system-area sap 0
439 result (* vm:vector-data-offset
441 (* length vm:byte-bits))
445 ;; kernel:copy-from-system-area doesn't work like it does on CMUCL or SBCL,
446 ;; so have to iteratively copy from sap
447 (defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
448 (declare (type system:system-area-pointer sap))
450 (declare (optimize (speed 3) (safety 0)))
451 (let ((null-terminated-length
452 (when null-terminated-p
454 for offset of-type fixnum upfrom 0
455 until (zerop (system:sap-ref-8 sap offset))
456 finally (return offset)))))
458 (if (and null-terminated-length
459 (> (the fixnum length) (the fixnum null-terminated-length)))
460 (setq length null-terminated-length))
461 (setq length null-terminated-length)))
462 (let ((result (make-string length)))
464 (declare (type fixnum i))
465 (setf (char result i) (code-char (system:sap-ref-8 sap i))))
468 #+(and sbcl (not sb-unicode))
469 (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
470 (declare (type sb-sys:system-area-pointer sap)
471 (type (or null fixnum) length))
473 (declare (optimize (speed 3) (safety 0)))
474 (let ((null-terminated-length
475 (when null-terminated-p
477 for offset of-type fixnum upfrom 0
478 until (zerop (sb-sys:sap-ref-8 sap offset))
479 finally (return offset)))))
481 (if (and null-terminated-length
482 (> (the fixnum length) (the fixnum null-terminated-length)))
483 (setq length null-terminated-length))
484 (setq length null-terminated-length)))
485 (let ((result (make-string length)))
486 (funcall *system-copy-fn* sap 0 result +system-copy-offset+
487 (* length +system-copy-multiplier+))
491 (eval-when (:compile-toplevel :load-toplevel :execute)
492 (def-function "strlen"
493 ((str (* :unsigned-char)))
494 :returning :unsigned-int))
496 (def-type char-ptr-def (* :unsigned-char))
498 #+(or (and allegro (not ics)) (and lispworks (not lispworks5) (not lispworks6)))
499 (defun fast-native-to-string (s len)
500 (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
501 (type char-ptr-def s))
502 (let* ((len (or len (strlen s)))
503 (str (make-string len)))
504 (declare (fixnum len)
505 (type (simple-array #+lispworks base-char
506 #-lispworks (signed-byte 8) (*)) str))
509 (uffi:deref-array s '(:array :char) i)))))
511 #+(or (and allegro ics) lispworks5 lispworks6)
512 (defun fast-native-to-string (s len)
513 (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
514 (type char-ptr-def s))
515 (let* ((len (or len (strlen s)))
516 (str (make-string len)))
518 (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))