;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: strings.lisp,v 1.10 2003/07/18 21:33:26 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
`(if (zerop ,obj)
nil
(if (eq ,locale :none)
- (fast-native-to-string ,obj)
- (excl:native-to-string
- ,obj
- ,@(when length (list :length length))
- :truncate (not ,null-terminated-p))))
+ (fast-native-to-string ,obj ,length)
+ (values
+ (excl:native-to-string
+ ,obj
+ ,@(when length (list :length length))
+ :truncate (not ,null-terminated-p)))))
#+lispworks
`(if (fli:null-pointer-p ,obj)
nil
(if (eq ,locale :none)
- (fast-native-to-string ,obj)
+ (fast-native-to-string ,obj ,length)
(fli:convert-from-foreign-string
,obj
,@(when length (list :length length))
#+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))
- #+(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)))))))
+
+ #+(or cmu scl)
+ `(alien:make-alien ,(if unsigned
+ '(alien:unsigned 8)
+ '(alien:signed 8))
+ ,size)
+
#+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
`(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))
result)))
#+sbcl
-(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
- (declare (type sb-sys:system-area-pointer sap))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (let ((null-terminated-length
- (when null-terminated-p
- (loop
- for offset of-type fixnum upfrom 0
- until (zerop (sb-sys:sap-ref-8 sap offset))
- finally (return offset)))))
- (if length
- (if (and null-terminated-length
- (> (the fixnum length) (the fixnum null-terminated-length)))
- (setq length null-terminated-length))
- (setq length null-terminated-length)))
- (let ((result (make-string length)))
- (sb-kernel:copy-from-system-area sap 0
- result (* sb-vm:vector-data-offset
- sb-vm:n-word-bits)
- (* length sb-vm:n-byte-bits))
- result)))
+(sb-ext:without-package-locks
+ (let ((copy-fn (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+ (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
+ (intern "COPY-UB8-FROM-SYSTEM" "SB-KERNEL"))))
+
+ #-sb-unicode
+ (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+ (declare (type sb-sys:system-area-pointer sap))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((null-terminated-length
+ (when null-terminated-p
+ (loop
+ for offset of-type fixnum upfrom 0
+ until (zerop (sb-sys:sap-ref-8 sap offset))
+ finally (return offset)))))
+ (if length
+ (if (and null-terminated-length
+ (> (the fixnum length) (the fixnum null-terminated-length)))
+ (setq length null-terminated-length))
+ (setq length null-terminated-length)))
+ (let ((result (make-string length)))
+ (funcall copy-fn sap 0
+ result (* sb-vm:vector-data-offset
+ sb-vm:n-word-bits)
+ (* length sb-vm:n-byte-bits))
+ result)))
+ #+sb-unicode
+ (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+ (declare (type sb-sys:system-area-pointer sap))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (cond
+ (null-terminated-p
+ (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char))
+ #+sb-unicode sb-alien:utf8-string
+ #-sb-unicode sb-alien:c-string)))
+ (if length
+ (copy-seq (subseq casted 0 length))
+ (copy-seq casted))))
+ (t
+ (let ((result (make-string length)))
+ ;; this will not work in sb-unicode
+ (funcall copy-fn sap 0
+ result (* sb-vm:vector-data-offset
+ sb-vm:n-word-bits)
+ (* 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))
#+(or lispworks (and allegro (not ics)))
-(defun fast-native-to-string (s)
+(defun fast-native-to-string (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
(type char-ptr-def s))
- (let* ((len (strlen s))
- (str (make-string len)))
+ (let* ((len (or len (strlen s)))
+ (str (make-string len)))
(declare (fixnum len)
(type (simple-array (signed-byte 8) (*)) str))
(dotimes (i len str)
- (setf (aref str i) (uffi:deref-array s '(:array :char) i)))))
+ (setf (aref str i)
+ (uffi:deref-array s '(:array :char) i)))))
#+(and allegro ics)
-(defun fast-native-to-string (s)
+(defun fast-native-to-string (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
(type char-ptr-def s))
- (let* ((len (strlen s))
- (str (make-string len)))
- (declare (fixnum len))
- (dotimes (i len str)
- (setf (schar str i) (ensure-char-character
- (uffi:deref-array s '(:array :char) i))))))
-
-#+ignore
-(defun fast-native-to-string (s)
- (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0) (debug 0))
- (type char-ptr-def s))
- (let* ((len (strlen s))
- (len4 (the fixnum (ash (the fixnum len) -2)))
- (end4 (the fixnum (ash (the fixnum len4) 2)))
- (remainder (the fixnum (- len end4)))
- (str (make-string len))
- (str4 str))
- (declare (type fixnum len len4 end4 remainder)
- (type (simple-array (signed-byte 32) (*)) str4)
- (type (simple-array (signed-byte 8) (*)) str))
- (dotimes (i len4)
- (declare (fixnum i))
- (setf (aref str4 i) (uffi:deref-array s '(:array :int) i)))
- (dotimes (i remainder)
- (declare (fixnum i))
- (setf (aref str end4) (uffi:deref-array s '(:array :char) end4))
- (incf end4))
- str))
+ (let* ((len (or len (strlen s)))
+ (str (make-string len)))
+ (dotimes (i len str)
+ (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))
projects / uffi.git / blobdiff