projects
/
uffi.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
r10124: revert change for openmcl that broke clsql
[uffi.git]
/
src
/
strings.lisp
diff --git
a/src/strings.lisp
b/src/strings.lisp
index 5fdbc89188037c2bc261cc60544e24289e1f2d88..c63d943e2c8e3496fb89056de87df03bb722bab1 100644
(file)
--- a/
src/strings.lisp
+++ b/
src/strings.lisp
@@
-157,10
+157,11
@@
that LW/CMU automatically converts strings from c-calls."
nil
(if (eq ,locale :none)
(fast-native-to-string ,obj ,length)
nil
(if (eq ,locale :none)
(fast-native-to-string ,obj ,length)
- (excl:native-to-string
- ,obj
- ,@(when length (list :length length))
- :truncate (not ,null-terminated-p))))
+ (values
+ (excl:native-to-string
+ ,obj
+ ,@(when length (list :length length))
+ :truncate (not ,null-terminated-p)))))
#+lispworks
`(if (fli:null-pointer-p ,obj)
nil
#+lispworks
`(if (fli:null-pointer-p ,obj)
nil
@@
-188,25
+189,34
@@
that LW/CMU automatically converts strings from c-calls."
#+mcl
`(if (ccl:%null-ptr-p ,obj)
nil
#+mcl
`(if (ccl:%null-ptr-p ,obj)
nil
- (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)))
+ #+(and mcl (not openmcl)) (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil))
+ #+openmcl ,@(if length
+ `((ccl:%str-from-ptr ,obj ,length))
+ `((ccl:%get-cstring ,obj))))
)
(defmacro allocate-foreign-string (size &key (unsigned t))
)
(defmacro allocate-foreign-string (size &key (unsigned t))
- #+
(or cmu scl)
+ #+
ignore
(let ((array-def (gensym)))
`(let ((,array-def (list 'alien:array 'c-call:char ,size)))
(eval `(alien:cast (alien:make-alien ,,array-def)
,(if ,unsigned
'(* (alien:unsigned 8))
'(* (alien:signed 8)))))))
(let ((array-def (gensym)))
`(let ((,array-def (list 'alien:array 'c-call:char ,size)))
(eval `(alien:cast (alien:make-alien ,,array-def)
,(if ,unsigned
'(* (alien:unsigned 8))
'(* (alien:signed 8)))))))
+
+ #+(or cmu scl)
+ `(alien:make-alien ,(if unsigned
+ '(alien:unsigned 8)
+ '(alien:signed 8))
+ ,size)
+
#+sbcl
#+sbcl
- (let ((array-def (gensym)))
- `(let ((,array-def (list 'sb-alien:array 'char ,size)))
- (eval `(sb-alien:cast (sb-alien:make-alien ,,array-def)
- ,(if ,unsigned
- '(* (sb-alien:unsigned 8))
- '(* (sb-alien:signed 8)))))))
+ `(sb-alien:make-alien ,(if unsigned
+ '(sb-alien:unsigned 8)
+ '(sb-alien:signed 8))
+ ,size)
+
#+lispworks
`(fli:allocate-foreign-object :type
,(if unsigned
#+lispworks
`(fli:allocate-foreign-object :type
,(if unsigned
@@
-223,6
+233,15
@@
that LW/CMU automatically converts strings from c-calls."
`(new-ptr ,size)
)
`(new-ptr ,size)
)
+(defun foreign-string-length (foreign-string)
+ #+allegro `(ff:foreign-strlen ,foreign-string)
+ #-allegro
+ `(loop with size = 0
+ until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
+ do (incf size)
+ finally return size))
+
+
(defmacro with-foreign-string ((foreign-string lisp-string) &body body)
(let ((result (gensym)))
`(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
(defmacro with-foreign-string ((foreign-string lisp-string) &body body)
(let ((result (gensym)))
`(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
@@
-303,10
+322,10
@@
that LW/CMU automatically converts strings from c-calls."
(* length sb-vm:n-byte-bits))
result)))
(* length sb-vm:n-byte-bits))
result)))
-
-(def-function "strlen"
- ((str (* :unsigned-char)))
-
:returning :unsigned-int
)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
(def-function "strlen"
+
((str (* :unsigned-char)))
+
:returning :unsigned-int)
)
(def-type char-ptr-def (* :unsigned-char))
(def-type char-ptr-def (* :unsigned-char))
@@
-329,4
+348,4
@@
that LW/CMU automatically converts strings from c-calls."
(let* ((len (or len (strlen s)))
(str (make-string len)))
(dotimes (i len str)
(let* ((len (or len (strlen s)))
(str (make-string len)))
(dotimes (i len str)
- (setf (
aref str i) (uffi:deref-array s '(:array :char) i
)))))
+ (setf (
schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i)
)))))