1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; strings.lisp --- Operations on foreign strings.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
7 ;;; Permission is hereby granted, free of charge, to any person
8 ;;; obtaining a copy of this software and associated documentation
9 ;;; files (the "Software"), to deal in the Software without
10 ;;; restriction, including without limitation the rights to use, copy,
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
12 ;;; of the Software, and to permit persons to whom the Software is
13 ;;; furnished to do so, subject to the following conditions:
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
25 ;;; DEALINGS IN THE SOFTWARE.
30 ;;;# Foreign String Conversion
32 ;;; Functions for converting NULL-terminated C-strings to Lisp strings
33 ;;; and vice versa. Currently this is blithely ignorant of encoding
34 ;;; and assumes characters can fit in 8 bits.
36 (defun lisp-string-to-foreign (string ptr size
)
37 "Copy at most SIZE-1 characters from a Lisp STRING to PTR.
38 The foreign string will be null-terminated."
42 (loop with i
= 0 for char across string
44 do
(%mem-set
(char-code char
) ptr
:unsigned-char
(post-incf i
))
45 finally
(%mem-set
0 ptr
:unsigned-char i
)))
46 ((array (unsigned-byte 8))
47 (loop with i
= 0 for elt across string
49 do
(%mem-set elt ptr
:unsigned-char
(post-incf i
))
50 finally
(%mem-set
0 ptr
:unsigned-char i
)))))
52 (defun foreign-string-to-lisp (ptr &optional
(size array-total-size-limit
)
53 (null-terminated-p t
))
54 "Copy at most SIZE characters from PTR into a Lisp string.
55 If PTR is a null pointer, returns nil."
56 (unless (null-pointer-p ptr
)
57 (with-output-to-string (s)
58 (loop for i fixnum from
0 below size
59 for code
= (mem-ref ptr
:unsigned-char i
)
60 until
(and null-terminated-p
(zerop code
))
61 do
(write-char (code-char code
) s
)))))
63 ;;;# Using Foreign Strings
65 (defun foreign-string-alloc (string)
66 "Allocate a foreign string containing Lisp string STRING.
67 The string must be freed with FOREIGN-STRING-FREE."
68 (check-type string
(or string
(array (unsigned-byte 8))))
69 (let* ((length (1+ (length string
)))
70 (ptr (foreign-alloc :char
:count length
)))
71 (lisp-string-to-foreign string ptr length
)
74 (defun foreign-string-free (ptr)
75 "Free a foreign string allocated by FOREIGN-STRING-ALLOC."
78 (defmacro with-foreign-string
((var lisp-string
) &body body
)
79 "Bind VAR to a foreign string containing LISP-STRING in BODY."
80 (with-unique-names (str length
)
81 `(let* ((,str
,lisp-string
)
83 (check-type ,str
(or string
(array (unsigned-byte 8))))
85 (with-foreign-pointer (,var
,length
)
86 (lisp-string-to-foreign ,str
,var
,length
)
89 (defmacro with-foreign-strings
(bindings &body body
)
91 `(with-foreign-string ,(first bindings
)
92 (with-foreign-strings ,(rest bindings
)
96 (defmacro with-foreign-pointer-as-string
((var size
&optional size-var
)
98 "Like WITH-FOREIGN-POINTER except VAR as a Lisp string is used as
99 the return value of an implicit PROGN around BODY."
100 `(with-foreign-pointer (,var
,size
,size-var
)
103 (foreign-string-to-lisp ,var
))))
105 ;;;# Automatic Conversion of Foreign Strings
107 (define-foreign-type foreign-string-type
()
109 (:actual-type
:pointer
)
110 (:simple-parser
:string
))
112 (defmethod translate-to-foreign ((s string
) (type foreign-string-type
))
113 (values (foreign-string-alloc s
) t
))
115 (defmethod translate-to-foreign (obj (type foreign-string-type
))
119 ((typep obj
'(array (unsigned-byte 8)))
120 (values (foreign-string-alloc obj
) t
))
121 (t (error "~A is not a Lisp string, (array (unsigned-byte 8)) or pointer."
124 (defmethod translate-from-foreign (ptr (type foreign-string-type
))
125 (foreign-string-to-lisp ptr
))
127 (defmethod free-translated-object (ptr (type foreign-string-type
) free-p
)
129 (foreign-string-free ptr
)))
133 (define-foreign-type foreign-string
+ptr-type
(foreign-string-type)
135 (:simple-parser
:string
+ptr
))
137 (defmethod translate-from-foreign (value (type foreign-string
+ptr-type
))
138 (list (foreign-string-to-lisp value
) value
))